字典-提取相关信息

沈默00

函数也可以的
=LET(t,UNIQUE(B2:B9),u,TRANSPOSE(SORT(UNIQUE(A2:A9))),HSTACK(VSTACK("合计",t),VSTACK(u,SUMIFS(C:C,A:A,u,B:B,t))))

ykcbf1100

参与一下。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()   '//2024.8.22  排重汇总
   
2.     Application.ScreenUpdating = False
   
3.     Application.DisplayAlerts = False
   
4.     Set d = CreateObject("Scripting.Dictionary")
   
5.     ReDim brr(1 To 10000, 1 To 100)
   
6.     m = 1: n = 1
   
7.     brr(1, 1) = "汇总"
   
8.     On Error Resume Next
   
9.     With Sheets("Sheet2")
   
10.         r = .Cells(Rows.Count, 1).End(3).Row
    
11.         arr = .[a1].Resize(r, 3)
    
12.         For i = 2 To UBound(arr)
    
13.             s = arr(i, 2)
    
14.             If Not d.exists(s) Then
    
15.                 m = m + 1
    
16.                 d(s) = m
    
17.                 brr(m, 1) = arr(i, 2)
    
18.             End If
    
19.             r = d(arr(i, 2))
    
20.             s = arr(i, 1)
    
21.             If Not d.exists(s) Then
    
22.                 n = n + 1
    
23.                 d(s) = n
    
24.                 brr(1, n) = s
    
25.             End If
    
26.             c = d(arr(i, 1))
    
27.             brr(r, c) = brr(r, c) + arr(i, 3)
    
28.         Next
    
29.         .[f:z].Clear
    
30.         .[f1].Resize(1, n).Interior.Color = 49407
    
31.         With .[f1].Resize(m, n)
    
32.             .Value = brr
    
33.             .Borders.LineStyle = 1
    
34.             .HorizontalAlignment = xlCenter
    
35.             .VerticalAlignment = xlCenter
    
36.         End With
    
37.     End With
    
38.     Application.ScreenUpdating = True
    
39.     MsgBox "OK！"
    
40. End Sub
    

复制代码

Qs18

Sub qs()
    Dim arr, i, d1, d2, d3
    Set d1 = CreateObject("scripting.dictionary")
    Set d2 = CreateObject("scripting.dictionary")
    Set d3 = CreateObject("scripting.dictionary")
    arr = Sheet1.Range("a1").CurrentRegion.Value
    For i = 2 To UBound(arr)
        s = arr(i, 1): ss = arr(i, 2)
        d1(s) = ""
        d2(ss) = ""
        If Not d3.exists(s & ss) Then
            d3(s & ss) = arr(i, 3)
        Else
            d3(s & ss) = d3(s & ss) + arr(i, 3)
        End If
    Next
    ReDim brr(1 To d2.Count + 1, 1 To d1.Count + 1)
    brr(1, 1) = "汇总"
    For Each k1 In d1.keys
        m = m + 1
        brr(1, 1 + m) = k1
    Next
    For Each k2 In d2.keys
        m2 = m2 + 1
        brr(m2 + 1, 1) = k2
    Next
    For i = 2 To UBound(brr)
        For j = 2 To UBound(brr, 2)
            brr(i, j) = d3(brr(1, j) & brr(i, 1))
        Next
    Next
    Sheet1.Range("f10").Resize(UBound(brr), UBound(brr, 2)) = brr
    Set d1 = Nothing: Set d2 = Nothing: Set d3 = Nothing
End Sub

Qs18

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

Qs18

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