- Sub Macro1()
- Dim arr, brr(1 To 60000, 1 To 5), d, i%, j&, s&, zf$, zf1$
- Set d = CreateObject("scripting.dictionary")
- For i = 1 To Sheets.Count
- If Sheets(i).Name <> "汇总表" Then
- zf = Mid(Sheets(i).Name, 2, 2)
- x = Application.Match(zf, Sheets(i).[a1:e1], 0)
- arr = Sheets(i).Range("a1").CurrentRegion
- For j = 2 To UBound(arr)
- zf1 = arr(j, 1)
- If Not d.exists(zf1) Then
- s = s + 1
- d(zf1) = s
- brr(s, 1) = arr(j, 1)
- brr(s, x) = arr(j, x)
- Else
- brr(d(zf1), x) = arr(j, x)
- End If
- Next
- End If
- Next
- Sheets("汇总表").Activate
- Range("a2:e20000").ClearContents
- Range("a2").Resize(s, 5) = brr
- End Sub
复制代码 |