老师们，学着用棋盘法写了个分类汇总，怎么再添加一行合计？

hzx091218

Sub xx()
Dim brr(1 To 50, 1 To 3), f
arr = Sheet1.UsedRange
Set d = CreateObject("scripting.dictionary")
For i = 1 To UBound(arr)
    If d(arr(i, 1)) Then
    f = d(arr(i, 1))
    brr(f, 2) = brr(f, 2) + arr(i, 2)
    brr(f, 3) = brr(f, 3) + arr(i, 3)
    Else
    k = k + 1
    d(arr(i, 1)) = k
    brr(k, 1) = arr(i, 1)
    brr(k, 2) = arr(i, 2)
    brr(k, 3) = arr(i, 3)
    End If
Next

Range("A13").Resize(k, 3) = brr


End Sub

hzx091218

想在汇总后 再加一栏合计~~

hzx091218

求助.rar (12.31 KB, 下载次数: 15)

2019-10-8 22:07 上传

点击文件名下载附件

shi353

Sub tt1()
Dim brr()
Sheet1.[A13:E65000].ClearContents
arr = Sheet1.[a1].CurrentRegion
Set d = CreateObject("scripting.dictionary")
For i = 2 To UBound(arr)
    If d.exists(arr(i, 1)) Then
       brr = d(arr(i, 1))
       brr(1, 1) = arr(i, 1)
       brr(1, 2) = brr(1, 2) + arr(i, 2)
       brr(1, 3) = brr(1, 3) + arr(i, 3)
       d(arr(i, 1)) = brr
    Else
       ReDim brr(1 To 1, 1 To 3)
       brr(1, 1) = arr(i, 1)
       brr(1, 2) = arr(i, 2)
       brr(1, 3) = arr(i, 3)
       d(arr(i, 1)) = brr
    End If
Next
'--------------------------------
A = Application.Index(arr, 1)
[A13].Resize(1, UBound(A)) = A
'--------------------------------
t1 = Application.Transpose(d.keys)
t2 = Application.Transpose(Application.Transpose(d.items))
[A14].Resize(UBound(t2), UBound(t2, 2)) = t2
'--------------------------------
Set b1 = [A13].CurrentRegion.Columns(2).Offset(1)
bb1 = b1.Resize(b1.Rows.Count - 1, 1).Address(0, 0)
[A65000].End(3).Offset(1) = "Total"
[B65000].End(3).Offset(1).Formula = "=sum(" & bb1 & ")"
'--------------------------------
Set b2 = [A13].CurrentRegion.Columns(3).Offset(1)
bb2 = b2.Resize(b1.Rows.Count - 1, 1).Address(0, 0)
[C65000].End(3).Offset(1).Formula = "=sum(" & bb2 & ")"
End Sub

wowo000

加这几句
r = Sheet1.[a65536].End(3).Row 'A列有数据最大行号
Sheet1.Cells(r + 1, 1) = "合计："
Sheet1.Cells(r + 1, 2) = "=Sum(b14:b" & r & ")"
Sheet1.Cells(r + 1, 3) = "=Sum(c14:c" & r & ")" '计算销售总金额
试试。

yaozong

hzx091218 发表于 2019-10-8 21:53
想在汇总后 再加一栏合计~~

Sub xx()
Dim brr(1 To 50, 1 To 3), f
arr = Sheet1.UsedRange
Set d = CreateObject("scripting.dictionary")
For i = 1 To UBound(arr)
  If i > 1 Then
    b = b + arr(i, 2)
    c = c + arr(i, 3)
  End If
    If d(arr(i, 1)) Then
    f = d(arr(i, 1))
    brr(f, 2) = brr(f, 2) + arr(i, 2)
    brr(f, 3) = brr(f, 3) + arr(i, 3)
    Else
    k = k + 1
    d(arr(i, 1)) = k
    brr(k, 1) = arr(i, 1)
    brr(k, 2) = arr(i, 2)
    brr(k, 3) = arr(i, 3)
    End If
Next
brr(k + 1, 1) = "合计"
brr(k + 1, 2) = b
brr(k + 1, 3) = c
Range("A13").Resize(k + 1, 3) = brr
End Sub