|
|
'前几天为一位坛友写了一个多个工作簿按照工作表名进行汇总的代码
'要求全年多个工作簿中的所有工作表按照工作表名进行汇总，每个同名工作表的列项目(物料名称)不相同，且列项目(物料名称)数据每个月都是增加
'以下拙作使用[字典嵌套]和[三维数组]对结构格式基本相同、同名工作表列项目不一致的多个工作簿按工作表名汇总
'代码有明显的缺点，为了获取工作表不重复的工作表名称和各工作表列项目的不重复值，每个工作簿需要使用GetObject函数调用两次，速度会有所欠缺
'这是我第一个主动发帖，学习vba仅一年余，不足之处敬请广大坛友批评指导
'代码：
Sub Macro1() '引用Microsoft Scripting Runtime
Dim arrw() As String, arr, brr(), crr(), sh As Worksheet
Dim d As New Dictionary, ds As New Dictionary, d1 As New Dictionary, d2 As New Dictionary, d3 As New Dictionary
Dim myPath$, myFile$, wb1 As Workbook, wb As Workbook, i&, j%, k%, m%, shc%, lc%, mxlc%
Set wb1 = ThisWorkbook
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For Each sh In Sheets
If sh.Name <> "总" Then sh.Delete '删除可能存在的已汇总工作表
Next
Application.DisplayAlerts = True
myPath = ThisWorkbook.Path & "\"
myFile = Dir(myPath & "*.xls")
Do While myFile <> ""
If myFile <> ThisWorkbook.Name Then
m = m + 1 '工作簿计数
ReDim Preserve arrw(1 To m) '重新定义工作簿路径数组
arrw(m) = myPath & myFile '记录工作簿路径
Set wb = GetObject(arrw(m)) '调用这个工作簿
For Each sh In wb.Sheets
With sh
If Not d.Exists(.Name) Then
Set d(.Name) = New Dictionary '[字典嵌套]定义各工作表行汇总字典，用以记录各工作不重复“客户名称”行号
Set ds(.Name) = New Dictionary '[字典嵌套]定义记录各工作表表头不重复项目列号字典
shc = shc + 1 '不重复工作表名称计数
d2(.Name) = shc '三维数组的第三维，即不重复工作表序号
Sheets.Add(After:=wb1.Sheets.Item(wb1.Sheets.Count)).Name = .Name '插入工作表，命名为不重复工作表名称
End If
lc = .Range("IV3").End(xlToLeft).Column '第3行最大列号
If InStr(.Cells(3, lc).Value, "计") > 0 Then lc = lc - 1 '-1去掉最后一列小计或合计列
arr = .Range("a3").Resize(1, lc) '数据区域，不含小计
For i = 1 To UBound(arr, 2) '逐列
If Not ds(.Name).Exists(arr(1, i)) Then '统计各个工作表表头不重复项目
d3(.Name) = d3(.Name) + 1 '各个工作表表头不重复项目计数(n = n + 1)
ds(.Name)(arr(1, i)) = d3(.Name) '记录各个工作表列号
End If
Next
End With
Next
wb.Close False
End If
myFile = Dir
Loop
For i = 2 To wb1.Sheets.Count '新建工作表逐表
ds(wb1.Sheets(i).Name)("小计") = d3(wb1.Sheets(i).Name) + 1 '每个工作表“小计”列号
If d3(wb1.Sheets(i).Name) > mxlc Then mxlc = d3(wb1.Sheets(i).Name) '记录各工作表最大列号
Next
ReDim brr(1 To 65530, 1 To mxlc, 1 To Sheets.Count - 1) '重新定义三维数组，第1维行，第2维列，第3维工作表序号
For k = 1 To m '逐个工作簿
Set wb = GetObject(arrw(k)) '调用工作簿
For Each sh In wb.Sheets '逐表
With sh
lc = .Range("IV3").End(xlToLeft).Column
If InStr(.Cells(3, lc).Value, "计") > 0 Then lc = lc - 1 '-1去掉最后一列小计
arr = .Range("a3").Resize(.Range("a65536").End(xlUp).Row - 3, lc) '-3为留1行表头，去掉最下面的“合计”行
For i = 2 To UBound(arr) '从第4行开始到倒数第2行
If arr(i, 1) <> "" Then '“客户名称”不为空
If Not d(.Name).Exists(arr(i, 1)) Then '该表第i行“客户名称”字典不存在
d1(.Name) = d1(.Name) + 1 '计数，相当于m=m+1
d(.Name)(arr(i, 1)) = d1(.Name) '“客户名称”添加到字典键值，不重复行数添加到字典条目。相当于d(arr(i, 1)) =m
For j = 1 To UBound(arr, 2) '逐列，不含小计
brr(d1(.Name), ds(.Name)(arr(1, j)), d2(.Name)) = arr(i, j) '没有判断列号字典ds(.Name)(arr(1, j))是否存在，它来自各工作簿的各个工作表
Next
Else '该表第i行“客户名称”字典已经存在
For j = 2 To UBound(arr, 2) '从第二列起累加同一个工作表同一个“客户名称”的项目
brr(d(.Name)(arr(i, 1)), ds(.Name)(arr(1, j)), d2(.Name)) = brr(d(.Name)(arr(i, 1)), ds(.Name)(arr(1, j)), d2(.Name)) + arr(i, j)
Next
End If
End If
Next
End With
Next
wb.Close False
Next
For Each sh In Sheets '逐表
If sh.Name <> "总" Then
With sh
.Range("a3").Resize(1, d3(.Name) + 1) = ds(.Name).Keys '写表头
ReDim crr(1 To d1(.Name), 1 To d3(.Name)) '重新定义二维数组，相当于行数=m，列数=不含小计的表头列数
For i = 1 To d1(.Name) '逐行
For j = 1 To d3(.Name) '逐列
crr(i, j) = brr(i, j, d2(.Name)) '把三维数组记录的该工作表行列数据写入二维数组crr
Next
Next
.Range("a4").Resize(d1(.Name), d3(.Name)) = crr '写数据
.Cells(4, d3(.Name) + 1).Resize(d1(.Name)) = "=SUM(RC2:RC" & d3(.Name) & ")" '最右边小计公式
.Cells(d1(.Name) + 4, 1).Value = "合计"
.Cells(d1(.Name) + 4, 2).Resize(1, d3(.Name)) = "=SUM(R4C:R" & d1(.Name) + 3 & "C)" '各个工作表数据区域最下面写合计公式
End With
End If
Next
Sheets(1).Activate
Application.ScreenUpdating = True
MsgBox "汇总完毕"
End Sub
学用[字典嵌套][三维数组]结构格式相同多个工作簿按工作表名汇总.rar
(67.55 KB, 下载次数: 2124)
|
评分
-
3
查看全部评分
-
|
[复制链接]
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2009-9-21 17:45
楼主
。
