去重对应汇总

jylai

请老师帮忙

ynzsvt

1. Sub 三列表转横竖表()
   
2. Dim Arr, DicXm As Object, DicFx As Object, i&, j&, Brr()
   
3. Set DicXm = CreateObject("Scripting.Dictionary")
   
4. Set DicFx = CreateObject("Scripting.Dictionary")
   
5. 
   
6. With Worksheets("Sheet1")
   
7.   Arr = .Range(.Cells(2, "C"), .Cells(Rows.Count, "A").End(xlUp))
   
8. End With
   
9. 
   
10. For i = 1 To UBound(Arr)
    
11.   If Not DicFx.exists(Arr(i, 3)) Then DicFx(Arr(i, 3)) = DicFx.Count + 1
    
12.   If Not DicXm.exists(Arr(i, 1)) Then DicXm(Arr(i, 1)) = DicXm.Count + 1
    
13. Next i
    
14. 
    
15. With Worksheets("Sheet1")
    
16.   .[F1].Offset(0, 1).Resize(1, DicFx.Count) = DicFx.keys
    
17.   .[F1].Offset(1, 0).Resize(DicXm.Count, 1) = Application.WorksheetFunction.Transpose(DicXm.keys)
    
18.   ReDim Brr(1 To DicXm.Count, 1 To DicFx.Count)
    
19.   For i = 1 To UBound(Arr)
    
20.    Brr(DicXm(Arr(i, 1)), DicFx(Arr(i, 3))) = Arr(i, 2)
    
21.   Next i
    
22.   .[F1].Offset(1, 1).Resize(DicXm.Count, DicFx.Count) = Brr
    
23. End With
    
24. 
    
25. Set DicFx = Nothing
    
26. Set DicXm = Nothing
    
27. End Sub

复制代码

ykcbf1100

字典排重汇总

ykcbf1100

参与一下。。。

1. Sub ykcbf()   '//2024.8.8  排重汇总
   
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.     On Error Resume Next
   
8.     With Sheets("Sheet1")
   
9.         r = .Cells(Rows.Count, 1).End(3).Row
   
10.         arr = .[a1].Resize(r, 3)
    
11.         For i = 2 To UBound(arr)
    
12.             s = arr(i, 1)
    
13.             If Not d.exists(s) Then
    
14.                 m = m + 1
    
15.                 d(s) = m
    
16.                 brr(m, 1) = arr(i, 1)
    
17.             End If
    
18.             r = d(arr(i, 1))
    
19.             s = arr(i, 3)
    
20.             If Not d.exists(s) Then
    
21.                 n = n + 1
    
22.                 d(s) = n
    
23.                 brr(1, n) = s
    
24.             End If
    
25.             c = d(arr(i, 3))
    
26.             brr(r, c) = brr(r, c) + arr(i, 2)
    
27.         Next
    
28.         [f10].Resize(m, n) = brr
    
29.     End With
    
30.     Application.ScreenUpdating = True
    
31.     MsgBox "OK！"
    
32. End Sub
    

复制代码

limonet

关键字：pivot

limonet

Sub limonet()
    Dim Cn As Object, StrSQL$, Rst As Object
    Set Cn = CreateObject("Adodb.Connection")
    Cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties='Excel 12.0;HDR=NO';Data Source=" & ThisWorkbook.FullName
    StrSQL = "TransForm Sum(F2) Select F1 as ' ' From [Sheet1$A2:C] Group By F1 Pivot F3"
    Set Rst = Cn.Execute(StrSQL)
    For j = 0 To Rst.Fields.Count - 1
        Cells(5, j + 6) = Rst.Fields(j).Name
    Next j
    Range("F6").CopyFromRecordset Rst
End Sub

jylai

感谢三位老师，您们太厉害了

还有一小小问题
请老师再次帮忙去重从小到大排顺序代码怎么改呢?

limonet

关键字：order by

jylai

limonet 发表于 2024-8-8 10:23
关键字：order by

老师我复制此到别的工作表用不了没有Microsoft.ACE.OLEDB.12.0去那里加载呢？

ivrdachen

这个用数据透视表最快，没必要写代码