VBA替代sumifs求和

maplecorn

因数据有几万行，表里还有其他数据表格，用sumifs求和就特别卡，想用vba替代求和

汇总表里的求和想用VBA替代，店铺+订单+产品型号 不仅包含明细里的数据，还有明细没有的

wqhsz385919

写了个，你看下
Private Sub CommandButton1_Click()
Dim d, arr, brr
Set d = CreateObject("scripting.dictionary")
arr = Range("a1").CurrentRegion
a = Range("a1").Resize(, 7)
ReDim brr(1 To UBound(arr), 1 To 7)
For i = 2 To UBound(arr)
    s = arr(i, 1) & "|" & arr(i, 2) & "|" & arr(i, 3)
    If Not d.exists(s) Then
       m = m + 1
       d(s) = m
       brr(m, 1) = arr(i, 1): brr(m, 2) = arr(i, 2): brr(m, 3) = arr(i, 3)
       For j = 4 To 7
           brr(m, j) = arr(i, j)
       Next

    Else
       r = d(s)
       For j = 4 To 7
           brr(r, j) = brr(r, j) + arr(i, j)
      Next
   End If
Next
   Range("k1").CurrentRegion = ""
   Range("k1").Resize(, 7) = a
   Range("k2").Resize(m, 7) = brr
End Sub

quqiyuan

参与一下，仅供参考。。。

quqiyuan

代码如下。。。
Sub test()
    Set wb = ThisWorkbook
    arr = wb.Sheets("明细").[a1].CurrentRegion
    Set d = CreateObject("scripting.dictionary")
    ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2))
    For i = 2 To UBound(arr)
        s = arr(i, 1) & "|" & arr(i, 2) & "|" & arr(i, 3)
        If Not d.exists(s) Then n = n + 1: d(s) = n
        m = d(s)
        For j = 1 To 3
            brr(m, j) = arr(i, j)
        Next
        For j = 4 To UBound(arr, 2)
            brr(m, j) = brr(m, j) + arr(i, j)
        Next
    Next
    With wb.Sheets("求和")
        .[a1].CurrentRegion.ClearContents
        .[a1].Resize(, UBound(brr, 2)) = arr
        .[a2].Resize(n, UBound(brr, 2)) = brr
    End With
    Set d = Nothing
    Beep
End Sub

maplecorn

quqiyuan 发表于 2024-10-1 07:56
参与一下，仅供参考。。。

我汇总表里还有别的数据，比如WAL+葡萄，那是明细表里没有的，那个也得留着。现在汇总后没了

maplecorn

quqiyuan 发表于 2024-10-1 07:56
参与一下，仅供参考。。。

你好，我汇总表里还有别的数据，比如WAL+葡萄，那是明细表里没有的，那个也得留着。现在汇总后没了

kyxfyzg

参与。。。。。。。

quqiyuan

maplecorn 发表于 2024-10-1 11:16
你好，我汇总表里还有别的数据，比如WAL+葡萄，那是明细表里没有的，那个也得留着。现在汇总后没了

修改一下，仅供参考。。。

quqiyuan

代码如下。。。
Sub test()
    Set wb = ThisWorkbook
    arr = wb.Sheets("明细").[a1].CurrentRegion
    drr = Application.Index(arr, 1)
    crr = wb.Sheets("求和").[a1].CurrentRegion
    Set d = CreateObject("scripting.dictionary")
    ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2))
    For i = 2 To UBound(arr)
        s = arr(i, 1) & "|" & arr(i, 2) & "|" & arr(i, 3)
        If Not d.exists(s) Then n = n + 1: d(s) = n
        m = d(s)
        For j = 1 To 3
            brr(m, j) = arr(i, j)
        Next
        For j = 4 To UBound(arr, 2)
            brr(m, j) = brr(m, j) + arr(i, j)
        Next
    Next
    For i = 2 To UBound(crr)
        s = crr(i, 1) & "|" & crr(i, 2) & "|" & crr(i, 3)
        m = d(s)
        If m > 0 Then
            For j = 4 To UBound(crr, 2)
                x = Application.Match(crr(1, j), drr, 0)
                If IsNumeric(x) Then crr(i, j) = brr(m, x)
            Next
        End If
    Next
    With wb.Sheets("求和")
        .[a1].Resize(UBound(crr), UBound(crr, 2)) = crr
    End With
    Set d = Nothing
    Beep
End Sub

lizhipei78