求VBA客户相同数量金额份数相加

syol

客户相同的合并，数量金额份数相加，发票号码始止 VBA 在Sheet2显示  求助大神！感谢！

chxw68

1. Sub test()
   
2.   Dim r%, i%
   
3.   Dim arr, brr
   
4.   Dim d As Object
   
5.   Set d = CreateObject("scripting.dictionary")
   
6.   With Worksheets("sheet1")
   
7.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
   
8.     arr = .Range("a2:g" & r)
   
9.   End With
   
10.   m = 0
    
11.   For i = 1 To UBound(arr)
    
12.     If Not d.exists(arr(i, 3)) Then
    
13.       m = m + 1
    
14.       ReDim brr(1 To 8)
    
15.       brr(1) = m
    
16.       brr(2) = arr(i, 2)
    
17.       brr(3) = arr(i, 3)
    
18.       brr(7) = arr(i, 7)
    
19.     Else
    
20.       brr = d(arr(i, 3))
    
21.     End If
    
22.     brr(4) = brr(4) + arr(i, 4)
    
23.     brr(5) = brr(5) + arr(i, 5)
    
24.     brr(6) = brr(6) + arr(i, 6)
    
25.     If brr(7) <> arr(i, 7) Then
    
26.       brr(8) = arr(i, 7)
    
27.     End If
    
28.     d(arr(i, 3)) = brr
    
29.   Next
    
30.   With Worksheets("sheet2")
    
31.     .UsedRange.Offset(1, 0).Clear
    
32.     .Range("a2").Resize(d.Count, UBound(brr)) = Application.Transpose(Application.Transpose(d.items))
    
33.   End With
    
34. End Sub
    

复制代码

chxw68

详见附件。

syol

感谢！！！解决我两个问题了！！

everbest2015

Sub 统计()
    Dim ar, br(), d As Object, i&, m&, k&, n&, h&, s$
    ar = Sheet1.Range("a1").CurrentRegion
    Set d = CreateObject("Scripting.Dictionary")
    For i = 2 To UBound(ar)
        s = ar(i, 3)
        If s <> "" Then
            If Not d.exists(s) Then
                m = m + 1
                d(s) = m
                ReDim Preserve br(1 To 8, 1 To m)
                h = h + 1
                br(1, m) = h
                For k = 2 To 7
                    br(k, m) = ar(i, k)
                Next
            Else
                n = d(s)
                br(4, n) = br(4, n) + ar(i, 4)
                br(5, n) = br(5, n) + ar(i, 5)
                br(6, n) = br(6, n) + ar(i, 6)
                If ar(i, 7) > br(7, n) Then br(8, n) = ar(i, 7)
            End If
        End If
    Next
    If m > 0 Then
    Application.ScreenUpdating = False
                Sheet2.Range("A2:H10000") = ""
                With Sheet2
                    .Range("a2").Resize(m, 8) = Application.Transpose(br)
                    With .Range("A:H")
                        .HorizontalAlignment = xlCenter
                        .VerticalAlignment = xlCenter
                        .EntireColumn.AutoFit
                    End With
                End With
        Application.ScreenUpdating = True
    Else
        MsgBox "没有统计到任何记录", , "请核实"
    End If
End Sub

everbest2015

请测试附件