|
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用 · 内置多项VBA编程加强工具 ★ 免费下载 ★ ★ 使用手册★
你的代码存在一个小Bug,如果被汇总的有一个空行就出错。
这是我修改后的代码
Sub 双条件求和1()
Dim d As Object
Dim arr As Variant
Dim i As Long
Dim j As Long
Dim m As Long
Dim r, r1
Set d = CreateObject("Scripting.Dictionary")
r1 = Sheet1.Cells(Rows.Count, 1).End(xlUp).Row
arr = Sheet1.Range("A2:c" & r1)
For i = 2 To UBound(arr)
' If IsNumeric(arr(i, 3)) Then
r = d(arr(i, 1) & arr(i, 2))
If r = "" Then
m = m + 1
d(arr(i, 1) & arr(i, 2)) = m 'm=r
For j = 1 To 3
arr(m, j) = arr(i, j)
Next
Else
arr(r, 3) = arr(r, 3) + arr(i, 3)
End If
' End If
Next
With Sheet2
.[A1].CurrentRegion.Offset(1).ClearContents
.[A2].Resize(m, 3) = arr
.Activate
End With
End Sub |
|