|
当我的工作薄超过3个以上时提示这个,3个以下就没问题
Sub 汇总2()
'On Error Resume Next
ActiveSheet.Rows("2:65536").ClearContents
Dim i, j, f, k, n, m
Dim wb As Workbook, sht As Worksheet
Dim d As Object, s
Dim arr, arr1()
Set d = CreateObject("scripting.dictionary")
s = Timer
f = Dir(ThisWorkbook.Path & "\*清单*.xlsx")
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Do While f <> ""
Set wb = Workbooks.Open(ThisWorkbook.Path & "\" & f)
For Each sht In Worksheets
sht.Activate
i = [a100000].End(3).Row
arr = Range("A3:F" & i)
For k = 1 To UBound(arr)
If Not d.exists(arr(k, 2) & arr(k, 3) & arr(k, 4)) Then
n = n + 1
d(arr(k, 2) & arr(k, 3) & arr(k, 4)) = n
ReDim Preserve arr1(1 To 7, 1 To n) '必须重新定义数组的维度
arr1(1, n) = arr(k, 2)
arr1(2, n) = arr(k, 3)
arr1(3, n) = arr(k, 4)
arr1(4, n) = arr(k, 5)
arr1(5, n) = arr(k, 6)
arr1(6, n) = Mid(wb.Name, 1, 5)
Else
m = d(arr(k, 2) & arr(k, 3) & arr(k, 4))
arr1(5, m) = arr1(5, m) + arr(k, 6)
arr1(6, m) = arr1(6, m) & "/" & Mid(wb.Name, 1, 5)
End If
Next k
Erase arr
Next sht
wb.Close False
f = Dir
Loop
Range("A2").Resize(d.Count, 7) = Application.Transpose(arr1)
MsgBox "汇总报表用时: " & Timer - s & " 秒"
End Sub
|
|