将EXCEL的sheet1页面的明细内容转换为sheet2页面的汇总内容

凡人灬

如何将sheet1页面第一行单元格内容分别为汇总的标题，第二行开始为明细，汇总为重新的次数，如附件

ykcbf1100

附件供参考。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()   '//2024.7.25    表格转换
   
2.     Application.ScreenUpdating = False
   
3.     Application.DisplayAlerts = False
   
4.     Set d = CreateObject("Scripting.Dictionary")
   
5.     ReDim brr(1 To 10000, 1 To 4)
   
6.     m = 1
   
7.     brr(1, 1) = "序号": brr(1, 2) = "部件名称"
   
8.     brr(1, 3) = "部件详细资料": brr(1, 4) = "数量"
   
9.     With Sheets("明细表")
   
10.         r = Cells(Rows.Count, 1).End(3).Row
    
11.         c = .UsedRange.Columns.Count
    
12.         arr = .[a1].Resize(r, c)
    
13.     End With
    
14.     For j = 3 To UBound(arr, 2)
    
15.         For i = 2 To UBound(arr)
    
16.             If arr(i, j) <> Empty Then
    
17.                 s = arr(1, j) & "|" & arr(i, j)
    
18.                 If Not d.exists(s) Then
    
19.                     m = m + 1
    
20.                     d(s) = m
    
21.                     brr(m, 1) = m - 1
    
22.                     brr(m, 2) = arr(1, j)
    
23.                     brr(m, 3) = arr(i, j)
    
24.                     brr(m, 4) = 1
    
25.                 Else
    
26.                     r = d(s)
    
27.                     brr(r, 4) = brr(r, 4) + 1
    
28.                 End If
    
29.             End If
    
30.         Next
    
31.     Next
    
32.     With Sheets("汇总表")
    
33.         .UsedRange.Clear
    
34.         .Cells.Interior.ColorIndex = 0
    
35.         .[a1].Resize(1, 4).Interior.Color = 49407
    
36.         With .[a1].Resize(m, 4)
    
37.             .Value = brr
    
38.             .Borders.LineStyle = 1
    
39.             .HorizontalAlignment = xlCenter
    
40.             .VerticalAlignment = xlCenter
    
41.             .EntireRow.AutoFit
    
42.             With .Font
    
43.                 .Name = "微软雅黑"
    
44.                 .Size = 11
    
45.             End With
    
46.         End With
    
47.         zr = Array(2)
    
48.         Call hb(2, 1, 2, zr)
    
49.     End With
    
50.     Set d = Nothing
    
51.     Application.ScreenUpdating = True
    
52.     MsgBox "OK！"
    
53. End Sub

复制代码

凡人灬

ykcbf1100 发表于 2024-7-25 20:45
参与一下。。。

谢谢老师，刚刚试了一下，很好用，比用excel筛选快了近百倍，非常感谢

chxw68

练习。。。