|
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件 ★ 免费下载 ★ ★ 使用帮助★
Sub 按钮1_Click()
Set d = CreateObject("scripting.dictionary")
Set dd = CreateObject("scripting.dictionary")
Dim sm As Double
Application.ScreenUpdating = False
arr = Sheets("数据表").UsedRange
Sheets("台账").UsedRange.Offset(6, 1).ClearContents
For j = 5 To UBound(arr)
If Len(arr(j, 2)) > 0 Then
str1 = ""
For i = 2 To 6
str1 = str1 & "," & arr(j, i)
Next i
str1 = Mid(str1, 2)
dd(str1) = ""
d(str1 & "," & arr(j, 7)) = d(str1 & "," & arr(j, 7)) & "," & j
End If
Next j
r = 7
For Each k In dd.keys
Cells(r, 2).Resize(1, 5) = Split(k, ",")
sm = 0
For Each c In Array(8, 20, 24, 28, 32)
If d.exists(k & "," & Cells(3, c)) Then
brr = Split(d(k & "," & Cells(3, c)), ",")
For i = 1 To UBound(brr)
sm = sm + arr(Val(brr(i)), 10)
Cells(r, c + (i - 1) * 2) = arr(Val(brr(i)), 8)
Cells(r, c + (i - 1) * 2 + 1) = arr(Val(brr(i)), 10)
Next i
End If
Next c
Cells(r, 7) = sm
r = r + 1
Next k
Application.ScreenUpdating = True
End Sub |
|