汇总问题

Qs18

试试................

Qs18

试试............

ykcbf1100

参与一下，字典+数组

ykcbf1100

参与一下。。。

1. Sub ykcbf()   '//2024.7.20
   
2.     Set d = CreateObject("Scripting.Dictionary")
   
3.     With Sheets("Sheet2")
   
4.         r = .Cells(Rows.Count, 1).End(3).Row
   
5.         arr = .[a1].Resize(r, 3)
   
6.     End With
   
7.     ReDim brr(1 To r, 1 To 3)
   
8.     For i = 2 To UBound(arr)
   
9.         s = arr(i, 1) & "|" & arr(i, 2)
   
10.         If Not d.exists(s) Then
    
11.             m = m + 1
    
12.             d(s) = m
    
13.             brr(m, 1) = arr(i, 1)
    
14.             brr(m, 2) = arr(i, 2)
    
15.             brr(m, 3) = arr(i, 3)
    
16.         Else
    
17.             r = d(s)
    
18.             brr(r, 3) = brr(r, 3) + arr(i, 3)
    
19.         End If
    
20.     Next
    
21.     With Sheets("Sheet1")
    
22.         .UsedRange.Offset(1).ClearContents
    
23.         .[a2].Resize(m, 3) = brr
    
24.     End With
    
25.     Set d = Nothing
    
26.     MsgBox "OK！"
    
27. End Sub
    

复制代码

gwjkkkkk

Option Explicit
Sub TEST6()
    Dim ar, br, i&, dic As Object, strKey$
   
    Application.ScreenUpdating = False
    Set dic = CreateObject("Scripting.Dictionary")
   
    ar = Worksheets(2).[A1].CurrentRegion.Value
    For i = 2 To UBound(ar)
        strKey = ar(i, 1) & ar(i, 2)
        If Not dic.exists(strKey) Then
            dic(strKey) = Array(ar(i, 1), ar(i, 2), ar(i, 3))
        Else
            br = dic(strKey)
            br(2) = br(2) + ar(i, 3)
            dic(strKey) = br
        End If
    Next i
   
    [H2].Resize(dic.Count, 3) = Application.Rept(dic.items, 1)
    Set dic = Nothing
    Application.ScreenUpdating = True
    Beep
End Sub

gwjkkkkk

参与一下。。。

zhangcheng6688

学习一下字典，打扰了
Sub test()
arr = Sheet2.[a1].CurrentRegion
Set d = CreateObject("scripting.dictionary")
ReDim brr(1 To UBound(arr), 1 To 3)
For i = 2 To UBound(arr)
   s = arr(i, 1) & arr(i, 2)
   If Not d.exists(s) Then
      m = m + 1
      For j = 1 To UBound(arr, 2)
         brr(m, j) = arr(i, j)
      Next
      d(s) = m
   Else
      r = d(s)
      brr(r, 3) = brr(r, 3) + arr(i, 3)
   End If
Next
Sheet1.[a1].CurrentRegion.Offset(1) = ClearContents
Sheet1.[a2].Resize(m, 3) = brr
End Sub

飞天篮球猪

飞天篮球猪

高版本用新函数GROUPBY也可以，速度一般。