[已解决]按客户合计数量和重量

ruhong18

按客户合计数量和重量

最佳答案

月排行榜 / 总排行榜

hasyh2008

2022-6-2 11:33

Sub 统计()
    Dim Arr, Brr(), K
    Dim Rc%, X%
    Dim Num1 As Single
    Dim Num2 As Single
    Dim Dic
    Set Dic = CreateObject("scripting.dictionary")
    Arr = Sheet1.Range("A1").CurrentRegion
    ReDim Brr(1 To 10000, 1 To 5)
    K = 0
    For Rc = 2 To UBound(Arr)
        If Dic.Exists(Arr(Rc, 2)) Then
            Brr(Dic(Arr(Rc, 2)), 3) = Brr(Dic(Arr(Rc, 2)), 3) + Arr(Rc, 6)
            Brr(Dic(Arr(Rc, 2)), 4) = Brr(Dic(Arr(Rc, 2)), 4) + Arr(Rc, 7)
        Else
            K = K + 1
            Dic(Arr(Rc, 2)) = K
            Brr(K, 1) = K: Brr(K, 2) = Arr(Rc, 2)
            Brr(K, 3) = Arr(Rc, 6): Brr(K, 4) = Arr(Rc, 7)
        End If
        Num1 = Num1 + Arr(Rc, 6)
        Num2 = Num2 + Arr(Rc, 7)
    Next Rc
    With Sheet2
        .Range("A3:E10000").ClearContents
        .Range("A2:E10000").Borders.LineStyle = xlNone
        .Range("A3:E" & K + 2) = Brr
        .Cells(K + 3, 1) = "合  计"
        .Range(.Cells(K + 3, 1), Cells(K + 3, 2)).HorizontalAlignment = xlCenterAcrossSelection
        .Cells(K + 3, 3) = Num1
        .Cells(K + 3, 4) = Num2
        With .Range(.Cells(2, 1), .Cells(K + 3, 5)).Borders
          .LineStyle = xlContinuous
          .Weight = xlThin
          .ColorIndex = 3
        End With
    End With
End Sub

跳转到最佳答案楼层

limonet

标准求和公式：=SUMIF(入库!$B:$B,合计!$B3,入库!F:F)
右拉下拉。

ruhong18

limonet 发表于 2022-6-1 17:09
标准求和公式：=SUMIF(入库!$B:$B,合计!$B3,入库!F:F)
右拉下拉。

感谢帮助，数据少的话可以用函数解决，但是数据多的话客户也多，而且客户不是固定的，所以用代码比较方便点~

limonet

ruhong18 发表于 2022-6-1 17:14
感谢帮助，数据少的话可以用函数解决，但是数据多的话客户也多，而且客户不是固定的，所以用代码比较方便 ...

数据多用推荐用透视表。

hasyh2008

Sub 统计()
    Dim Arr, Brr(), K
    Dim Rc%, X%
    Dim Dic
    Set Dic = CreateObject("scripting.dictionary")
    Arr = Sheet1.Range("A1").CurrentRegion
    ReDim Brr(1 To 1000, 1 To 5)
    K = 0
    For Rc = 2 To UBound(Arr)
        If Dic.Exists(Arr(Rc, 2)) Then
            Brr(Dic(Arr(Rc, 2)), 3) = Brr(Dic(Arr(Rc, 2)), 3) + Arr(Rc, 6)
            Brr(Dic(Arr(Rc, 2)), 4) = Brr(Dic(Arr(Rc, 2)), 4) + Arr(Rc, 7)
        Else
            K = K + 1
            Dic(Arr(Rc, 2)) = K
            Brr(K, 1) = K: Brr(K, 2) = Arr(Rc, 2)
            Brr(K, 3) = Arr(Rc, 6): Brr(K, 4) = Arr(Rc, 7)
        End If
    Next Rc
    With Sheet2
        .Range("A3:E1000").ClearContents
        .Range("A3:E" & K + 2) = Brr
        .Cells(K + 3, 2) = "合  计"
        .Cells(K + 3, 3) = Application.Sum(.Range("C3:C" & K + 2))
        .Cells(K + 3, 4) = Application.Sum(.Range("D3:D" & K + 2))
    End With
End Sub

hasyh2008

Sub 统计()
    Dim Arr, Brr(), K
    Dim Rc%, X%
    Dim Num1 As Single
    Dim Num2 As Single
    Dim Dic
    Set Dic = CreateObject("scripting.dictionary")
    Arr = Sheet1.Range("A1").CurrentRegion
    ReDim Brr(1 To 10000, 1 To 5)
    K = 0
    For Rc = 2 To UBound(Arr)
        If Dic.Exists(Arr(Rc, 2)) Then
            Brr(Dic(Arr(Rc, 2)), 3) = Brr(Dic(Arr(Rc, 2)), 3) + Arr(Rc, 6)
            Brr(Dic(Arr(Rc, 2)), 4) = Brr(Dic(Arr(Rc, 2)), 4) + Arr(Rc, 7)
        Else
            K = K + 1
            Dic(Arr(Rc, 2)) = K
            Brr(K, 1) = K: Brr(K, 2) = Arr(Rc, 2)
            Brr(K, 3) = Arr(Rc, 6): Brr(K, 4) = Arr(Rc, 7)
        End If
        Num1 = Num1 + Arr(Rc, 6)
        Num2 = Num2 + Arr(Rc, 7)
    Next Rc
    With Sheet2
        .Range("A3:E10000").ClearContents
        .Range("A2:E10000").Borders.LineStyle = xlNone
        .Range("A3:E" & K + 2) = Brr
        .Cells(K + 3, 1) = "合  计"
        .Range(.Cells(K + 3, 1), Cells(K + 3, 2)).HorizontalAlignment = xlCenterAcrossSelection
        .Cells(K + 3, 3) = Num1
        .Cells(K + 3, 4) = Num2
        With .Range(.Cells(2, 1), .Cells(K + 3, 5)).Borders
          .LineStyle = xlContinuous
          .Weight = xlThin
          .ColorIndex = 3
        End With
    End With
End Sub