Public Sub Basic_CodeFrame()
AppSettings
On Error GoTo ErrHandler
Dim StartTime, UsedTime As Variant
StartTime = VBA.Timer
'Input code here Call SubTotalData UsedTime = VBA.Timer - StartTime
'Debug.Print "UsedTime:" & Format(UsedTime, "0.000 Seconds")
MsgBox "UsedTime:" & Format(UsedTime, "0.000 Seconds"), vbOKOnly, "NS QQ "
ErrorExit:
AppSettings False
Exit Sub
ErrHandler:
If Err.Number <> 0 Then
MsgBox Err.Description & "!", vbCritical, "NextSeven QQ "
Debug.Print Err.Description
Err.Clear
Resume ErrorExit
End If
End Sub
Public Sub AppSettings(Optional IsStart As Boolean = True)
If IsStart Then
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.Calculation = xlCalculationManual
Application.StatusBar = ">>>>>>>>Macro Is Running>>>>>>>>"
Else
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
Application.StatusBar = False
End If
End Sub Private Sub SubTotalData()
Dim dShtName As Object
Dim dInfo As Object
Dim Key As String
Dim OneKey
Const MAIN_SHEET As String = "分类汇总表"
Const SALE_SHEET As String = "销售数据汇总表"
Const PROC_SHEET As String = "生产入库明细表"
Const STORE_SHEET As String = "汇总后库存明细表"
Const HEAD_ROW As Long = 3
Const END_COL As String = "Z"
Dim EndRow As Long
Dim Wb As Workbook Dim Sht As Worksheet
Dim oSht As Worksheet
Dim Rng As Range
Dim Arr As Variant
Dim Data() As Variant Set Wb = Application.ThisWorkbook
Set Sht = Wb.Worksheets(MAIN_SHEET) Set dShtName = CreateObject("Scripting.Dictionary")
Set dInfo = CreateObject("Scripting.Dictionary") Key = MAIN_SHEET
dShtName(Key) = "" Key = SALE_SHEET
dShtName(Key) = "" Key = PROC_SHEET
dShtName(Key) = "" Key = STORE_SHEET
dShtName(Key) = "" For Each oSht In Wb.Worksheets
If dShtName.EXISTS(oSht.Name) = False Then
With oSht
EndRow = .Cells(.Cells.Rows.Count, 2).End(xlUp).Row
Set Rng = .Range(.Cells(HEAD_ROW + 1, "A"), .Cells(EndRow, END_COL))
Arr = Rng.Value
For i = LBound(Arr) To UBound(Arr)
Key = CStr(Arr(i, 3))
Item = CStr(Arr(i, 3)) & ";" & CStr(Arr(i, 4)) & _
";" & CStr(Arr(i, 5)) & ";" & CStr(Arr(i, 6))
'Debug.Print Item
dInfo(Key) = Item
Next i
End With
End If
Next oSht ReDim Data(1 To 14, 1 To 1)
Dim Index As Long
Dim PlanIndex As Long
Dim SaleIndex As Long
Dim ProcIndex As Long
Dim StoreIndex As Long Index = 0
PlanIndex = Index
SaleIndex = Index
ProcIndex = Index
StoreIndex = Index For Each OneKey In dInfo.keys
Key = OneKey
'循环所有部门工作表
For Each oSht In Wb.Worksheets
If dShtName.EXISTS(oSht.Name) = False Then
With oSht
EndRow = .Cells(.Cells.Rows.Count, 2).End(xlUp).Row
Set Rng = .Range(.Cells(HEAD_ROW + 1, "A"), .Cells(EndRow, END_COL))
Arr = Rng.Value
For i = LBound(Arr) To UBound(Arr)
If CStr(Arr(i, 3)) = Key Then
PlanIndex = PlanIndex + 1 '计划生产部分 ReDim Preserve Data(1 To 14, 1 To PlanIndex)
info = Split(dInfo(Key), ";")
For n = LBound(info) To UBound(info)
Data(n + 1, PlanIndex) = info(n)
Next n
Data(5, PlanIndex) = Format(Arr(i, 1), "yyyy/mm/dd") '日期
Data(6, PlanIndex) = Arr(i, 8)
Data(7, PlanIndex) = Arr(i, 2)
End If
Next i
End With
End If
Next oSht Index = Application.WorksheetFunction.Max(PlanIndex, SaleIndex, ProcIndex, StoreIndex) '保存最大行号
Set oSht = Wb.Worksheets(PROC_SHEET)
With oSht
EndRow = .Cells(.Cells.Rows.Count, 2).End(xlUp).Row
Set Rng = .Range(.Cells(HEAD_ROW + 1, "A"), .Cells(EndRow, END_COL))
Arr = Rng.Value
For i = LBound(Arr) To UBound(Arr)
If CStr(Arr(i, 15)) = Key Then
ProcIndex = ProcIndex + 1 '计划生产部分
'重定义数组
If ProcIndex > Index Then ReDim Preserve Data(1 To 14, 1 To ProcIndex) info = Split(dInfo(Key), ";")
For n = LBound(info) To UBound(info)
Data(n + 1, ProcIndex) = info(n)
Next n Data(8, ProcIndex) = Format(Arr(i, 4), "yyyy/mm/dd") '日期
Data(9, ProcIndex) = Arr(i, 19)
Data(10, ProcIndex) = Arr(i, 13)
End If
Next i
End With Index = Application.WorksheetFunction.Max(PlanIndex, SaleIndex, ProcIndex, StoreIndex) '保存最大行号
Set oSht = Wb.Worksheets(SALE_SHEET)
With oSht
EndRow = .Cells(.Cells.Rows.Count, 2).End(xlUp).Row
Set Rng = .Range(.Cells(HEAD_ROW + 1, "A"), .Cells(EndRow, END_COL))
Arr = Rng.Value
For i = LBound(Arr) To UBound(Arr)
If CStr(Arr(i, 17)) = Key Then
SaleIndex = SaleIndex + 1 '计划生产部分
'重定义数组
If SaleIndex > Index Then ReDim Preserve Data(1 To 14, 1 To SaleIndex)
info = Split(dInfo(Key), ";")
For n = LBound(info) To UBound(info)
Data(n + 1, SaleIndex) = info(n)
Next n
Data(11, SaleIndex) = Arr(i, 6)
Data(12, SaleIndex) = Arr(i, 21) End If
Next i
End With Index = Application.WorksheetFunction.Max(PlanIndex, SaleIndex, ProcIndex, StoreIndex) '保存最大行号
Set oSht = Wb.Worksheets(STORE_SHEET)
With oSht
EndRow = .Cells(.Cells.Rows.Count, 2).End(xlUp).Row
Set Rng = .Range(.Cells(HEAD_ROW + 1, "A"), .Cells(EndRow, END_COL))
Arr = Rng.Value
For i = LBound(Arr) To UBound(Arr)
If CStr(Arr(i, 2)) = Key Then
StoreIndex = StoreIndex + 1 '计划生产部分
'重定义数组
If StoreIndex > Index Then ReDim Preserve Data(1 To 14, 1 To StoreIndex)
info = Split(dInfo(Key), ";")
For n = LBound(info) To UBound(info)
Data(n + 1, StoreIndex) = info(n)
Next n Data(13, StoreIndex) = Arr(i, 6)
Data(14, StoreIndex) = Format(Arr(i, 4), "yyyy/mm/dd") End If
Next i
End With '再次初始化
Index = Application.WorksheetFunction.Max(PlanIndex, SaleIndex, ProcIndex, StoreIndex) '保存最大行号
PlanIndex = Index
SaleIndex = Index
ProcIndex = Index
StoreIndex = Index Next OneKey Index = Application.WorksheetFunction.Max(PlanIndex, SaleIndex, ProcIndex, StoreIndex) With Sht
.UsedRange.Offset(2).Clear
Set Rng = .Range("A3").Resize(Index, 14)
Rng.Value = Application.WorksheetFunction.Transpose(Data) '输出数组
MergeSameItem .UsedRange '合并同项
SetEdges .UsedRange '设置居中与边框
End With End Sub
Private Sub MergeSameItem(ByVal RngWithTitle As Range)
'禁止合并单元格过程中出现警告提示
Application.DisplayAlerts = False
Dim i As Integer
Dim RowCount As Long
Dim LastRow As Long
Dim FirstRow As Long
With RngWithTitle
'根据A列序号合并A列
RowCount = .Cells.Rows.Count
LastRow = RowCount For i = RowCount To 2 Step -1
If .Cells(i, "A").Value <> .Cells(i - 1, "A").Value Then '若前后行内容不同
FirstRow = i '记下合并区域的起始行 .Cells(FirstRow, "A").Resize(LastRow - FirstRow + 1, 1).Merge '拓展选区
.Cells(FirstRow, "B").Resize(LastRow - FirstRow + 1, 1).Merge '拓展选区
.Cells(FirstRow, "C").Resize(LastRow - FirstRow + 1, 1).Merge '拓展选区
.Cells(FirstRow, "D").Resize(LastRow - FirstRow + 1, 1).Merge '拓展选区 LastRow = i - 1 '调整下一个区域的终止行
End If
Next i End With
Application.DisplayAlerts = True '恢复警告提示
End Sub
Private Sub SetEdges(ByVal Rng As Range)
With Rng
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter With .Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With .Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With .Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With .Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
If .Cells.Count > 1 Then
With .Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With .Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
End If
End With
End Sub

  

20170622xlVBA多部门分类汇总同类合并单元格的更多相关文章

  1. DataTables合并单元格(rowspan)的实现思路(多分组分类的情况)

    直接上代码,原理之前的随笔已经讲过了.http://www.cnblogs.com/hdwang/p/7115835.html 1.先看看效果 2.html代码,含js代码 2.1 common.js ...

  2. postgresql高级应用之合并单元格

    postgresql高级应用之合并单元格 转载请注明出处https://www.cnblogs.com/funnyzpc/p/14732172.html 1.写在前面✍ 继上一篇postgresql高 ...

  3. 【记录】解析具有合并单元格的Excel

    最近公司让做各种数据表格的导入导出,就涉及到电子表格的解析,做了这么多天总结一下心得. 工具:NOPI 语言:C# 目的:因为涉及到导入到数据库,具有合并单元格的多行必然要拆分,而NPOI自动解析的时 ...

  4. poi excel 合并单元格

    结论:final CellRangeAddress cra = new CellRangeAddress(rowId, rowId + rowSkip,        colId, colId + c ...

  5. 【开发者笔记】解析具有合并单元格的Excel

    最近公司让做各种数据表格的导入导出,就涉及到电子表格的解析,做了这么多天总结一下心得. 工具:NOPI 语言:C# 目的:因为涉及到导入到数据库,具有合并单元格的多行必然要拆分,而NPOI自动解析的时 ...

  6. npoi导出excel合并单元格

    需要引用NPOI.dll程序集和Ionic.Zip.dll程序集 string[] headerRowName = { "序号", "地市", "镇街 ...

  7. react antd Table动态合并单元格

    示例数据 原始数组 const data = [ { key: '0', name: 'John Brown', age:22, address: 'New York No. 1 Lake Park' ...

  8. java导出标题多行且合并单元格的EXCEL

    场景:项目中遇到有需要导出Excel的需求,并且是多行标题且有合并单元格的,参考网上的文章,加上自己的理解,封装成了可自由扩展的导出工具 先上效果,再贴代码: 调用工具类进行导出: public st ...

  9. 导出excel带合并单元格方法的Demo

    package com.test.util; import java.io.FileNotFoundException; import java.io.FileOutputStream; import ...

随机推荐

  1. jquery ui draggable,droppable 学习总结

    刚接触的时候,分不清draggable和droppable的区别,瞎弄了一会,其实很简单,draggable就是“拖”的功能,droppable就是“放”的功能. draggable()是被拖动的元素 ...

  2. 借助IDE到处Runnable JAR 的步骤

    1. 选择项目,右键,export,选择Java目录下的Runnable JAR file , next 2. Lanch configuration 中选择启动类 3. Export destina ...

  3. Linux基础命令---cal

    cal cal指令可以显示一个日历信息,如果没有指定选项和参数,那么就会显示当前的月份. 此命令的适用范围:RedHat.RHEL.Ubuntu.CentOS.SUSE.openSUSE.Fedora ...

  4. Qt的四个常见的图像叠加模式

    Qt的QPainter::CompositionMode提供了多种图像叠加的模式.常见的有QPainter::CompositionMode_SourceOver, QPainter::Composi ...

  5. python 操作 hbase

    python 是万能的,当然也可以通过api去操作big database 的hbase了,python是通过thrift去访问操作hbase 以下是在centos7 上安装操作,前提是hbase已经 ...

  6. Rapid 2D-to-3D conversion——快速2D到3D转换

    https://blog.csdn.net/qq_33445835/article/details/80143598  目前想做一个关于2D转3D的项目,由于国内资料比较少而且大部分都是基于国外的研究 ...

  7. 什么叫集群、分布式,分布式与集群有什么区别?(康神sf讲座学习笔记)

    集群是物理形态,分布式是工作方式. 只要一堆机器放在那里,就是集群.比如Nginx后面的十台服务器,就是一个集群 分布式将任务放在多个物理隔离的节点上进行. 分布式中各个子节点互不通信,统一受管控中心 ...

  8. keepalived+nginx实现HA高可用的web负载均衡

    Keepalived 是一种高性能的服务器高可用或热备解决方案, Keepalived 可以用来防止服务器单点故障的发生,通过配合 Nginx 可以实现 web 前端服务的高可用.Keepalived ...

  9. Socket:读写处理及连接断开的检测

    作为进程间通信及网络通信的一种重要技术,在实际的开发中,socket编程是经常被用到的.关于socket编程的一般步骤,这里不再赘述,相关资料和文章很多,google/baidu即可. 本文主要是探讨 ...

  10. git源码阅读

    https://github.com/git-for-windows/git/issues/1854 https://github.com/git-for-windows/git/pull/1902/ ...