- Sub test()
- Dim i%, j%, wks, d, arr, str, arr1()
- Set d = CreateObject("scripting.dictionary")
- For Each wks In ThisWorkbook.Sheets
- If wks.Name <> "表四" Then
- arr = wks.[a1].CurrentRegion
- For i = 4 To UBound(arr)
- For j = 3 To UBound(arr, 2)
- If arr(i, 1) <> "" And arr(3, j) <> "" And arr(i, j) <> "" Then
- str = arr(i, 2) & "," & arr(2, j)
- d(str) = d(str) + arr(i, j)
- End If
- Next
- Next
- End If
- Next
- arr = d.keys
- For i = 0 To UBound(arr)
- ReDim Preserve arr1(1 To 3, 1 To i + 1)
- arr1(1, i + 1) = Split(arr(i), ",")(0)
- arr1(2, i + 1) = Split(arr(i), ",")(1)
- arr1(3, i + 1) = d(arr(i))
- Next
- Sheets("表四").[a2].Resize(UBound(arr1, 2), UBound(arr1)) = WorksheetFunction.Transpose(arr1)
- Sheets("表四").[a1].CurrentRegion.Sort key1:="姓名", order1:=xlAscending, Header:=xlYes
- End Sub
复制代码 |