|
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件 ★ 免费下载 ★ ★ 使用帮助★
- Sub result()
- Dim i&, j&, d, arr, brr(), aa
- Set d = CreateObject("scripting.dictionary")
- cc = Array("b", "c")
- For Each ws In Sheets
- If ws.Name <> "Sheet4" Then
- With ws
- r = .Cells(Rows.Count, 1).End(3).Row
- arr = .Range("A1:C" & r)
- For i = 2 To UBound(arr)
- For j = 2 To UBound(arr, 2)
- s = arr(i, 1) & "," & arr(1, j)
- d(s) = arr(i, j) + d(s)
- Next
- Next
- End With
- End If
- Next
- k = d.keys
- t = d.items
- m = 1
- d.RemoveAll
- ReDim brr(1 To 3, 1 To m)
- For i = 0 To UBound(k)
- aa = Split(k(i), ",")
- For j = 0 To UBound(cc)
- If aa(1) = cc(j) Then
- If d.exists(aa(0)) Then
- brr(j + 2, d(aa(0))) = t(i) + brr(j + 2, d(aa(0)))
- Else
-
-
- brr(1, m) = aa(0)
- brr(j + 2, m) = t(i) + brr(j + 2, m)
- d(aa(0)) = m
- m = m + 1
- ReDim Preserve brr(1 To 3, 1 To m)
- End If
- End If
- Next
- Next
-
- With Sheets("Sheet4")
- .[a2].Resize(UBound(brr, 2), 3) = Application.Transpose(brr)
- '.[b1].Resize(d.Count) = WorksheetFunction.Transpose(d.items)
- End With
-
-
- End Sub
复制代码 |
|