请测试:- Sub Macro1()
- Dim p$, f$, arr, brr(1 To 60000, 1 To 256), d As Object, ds As Object, i&, j, m&, n&, r, y$
- Set d = CreateObject("scripting.dictionary")
- Set ds = CreateObject("scripting.dictionary")
- ds("单位") = 1
- ds("年") = 2
- n = 2
- p = ThisWorkbook.Path & ""
- f = Dir(p & "*.xls")
- Application.ScreenUpdating = False
- Do While f <> ""
- If f <> ThisWorkbook.Name Then
- With GetObject(p & f)
- arr = .Sheets(1).[a1].CurrentRegion
- .Close False
- End With
- If IsArray(arr) Then
- y = Left$(f, 4)
- For j = 2 To UBound(arr, 2)
- If Not ds.Exists(arr(1, j)) Then
- n = n + 1
- ds(arr(1, j)) = n
- End If
- Next
- For i = 2 To UBound(arr)
- s = arr(i, 1) & Chr(9) & y & Chr(9) & arr(i, 2) & Chr(9) & arr(i, 3)
- r = d(s)
- If r = "" Then
- m = m + 1
- d(s) = m
- brr(m, 1) = arr(i, 1)
- brr(m, 2) = y
- For j = 2 To UBound(arr, 2)
- brr(m, ds(arr(1, j))) = arr(i, j)
- Next
- Else
- For j = 4 To UBound(arr, 2)
- brr(r, ds(arr(1, j))) = brr(r, ds(arr(1, j))) + arr(i, j)
- Next
- End If
- Next
- End If
- End If
- f = Dir
- Loop
- Cells.ClearContents
- [a1].Resize(, n) = ds.keys
- [a2].Resize(m, n) = brr
- Application.ScreenUpdating = True
- End Sub
复制代码 |