|
- Sub Macro1()
- Dim MyPath$, MyName$, d As Object, Arr, Brr(1 To 60000, 1 To 22), i&, j&, m&, s$
- Application.ScreenUpdating = False
- Set d = CreateObject("scripting.dictionary")
- MyPath = ThisWorkbook.Path & "\分表"
- MyName = Dir(MyPath & "*.xls")
- Do While MyName <> ""
- With GetObject(MyPath & MyName)
- Arr = .Sheets(1).[a1].CurrentRegion
- For i = 2 To UBound(Arr)
- s = Arr(i, 1) & "," & Arr(i, 6) & "," & Arr(i, 10) & "," & Arr(i, 12)
- If Not d.Exists(s) Then
- d(s) = Arr(i, 14)
- m = m + 1
- For j = 1 To UBound(Arr, 2)
- Brr(m, j) = Arr(i, j)
- Next
- Brr(m, 14) = d(s)
- Else
- d(s) = d(s) + Arr(i, 14)
- For j = 1 To m
- s1 = Brr(j, 1) & "," & Brr(j, 6) & "," & Brr(j, 10) & "," & Brr(j, 12)
- If s1 = s Then Brr(j, 14) = d(s): Exit For
- Next
- End If
- Next
- .Close False
- End With
- MyName = Dir
- Loop
- ActiveSheet.UsedRange.Offset(1).ClearContents
- [a2].Resize(m, 22) = Brr
- Application.ScreenUpdating = True
- End Sub
复制代码 |
|