多个工作表的数据自动汇总到 汇总 表格内

ykcbf1100

XL3750727 发表于 2022-11-22 16:56
草爷，帮我看看这个贴子里在那个附件，谢谢您了。

满足你的要求。

XL3750727

ykcbf1100 发表于 2022-11-23 09:11
满足你的要求。

谢谢草爷了，没想到效率这么高，高手就是不一样。真心谢谢了。

夜上海

更谢谢草爷  简单方便

ykcbf1100

代码重写，优化一下代码，自动跳过空表，自动跳过空行，字典固定列号，自动避坑

ykcbf1100

1. Sub ykcbf()            '//2025.3.20   多表合并
   
2.     Application.ScreenUpdating = False
   
3.     Application.DisplayAlerts = False
   
4.     Dim tm: tm = Timer
   
5.     Set d = CreateObject("scripting.dictionary")
   
6.     ReDim brr(1 To 10 ^ 5, 1 To 100)
   
7.     Set sh = Sheets("汇总")
   
8.     arr = sh.UsedRange
   
9.     For j = 1 To UBound(arr, 2)
   
10.         d(arr(1, j)) = j        '//字典固定列号
    
11.     Next
    
12.     On Error Resume Next
    
13.     For Each sht In Sheets
    
14.         If sht.Name <> sh.Name Then
    
15.             If sht.UsedRange.Count > 1 Then  '//跳过空表
    
16.                 With sht
    
17.                     arr = sht.UsedRange
    
18.                     c1 = .Rows(4).Find("申购数量").Column
    
19.                 End With
    
20.                 For i = 5 To UBound(arr)
    
21.                     If Val(arr(i, c1)) > 0 Then    '//跳过空行
    
22.                         m = m + 1
    
23.                         brr(m, 1) = sht.Name
    
24.                         For j = 1 To UBound(arr, 2)
    
25.                             s = arr(4, j)
    
26.                             If d.exists(s) Then
    
27.                                 brr(m, d(s)) = arr(i, j)
    
28.                             End If
    
29.                         Next j
    
30.                     End If
    
31.                 Next i
    
32.             End If
    
33.         End If
    
34.     Next
    
35.     With sh
    
36.         .UsedRange.Offset(1) = Empty
    
37.         .[a2].Resize(m, 9) = brr
    
38.         .[a2].Resize(m, 9).Borders.LineStyle = 1
    
39.     End With
    
40.     Set d = Nothing
    
41.     MsgBox "共用时：" & Format(Timer - tm, "0.000") & "秒！"
    
42. End Sub
    

复制代码

lyfegf

1. Dim f As New clsFunc
   
2. Sub Main()
   
3.     Dim i&, r, j&, y&, n&, m&, x, arr, brr, arrjg, cRow As New Collection
   
4.     Dim sht As Worksheet, hd As New cls_head_datas
   
5.     Dim cTitle As New Collection, rng As Range
   
6.     Dim dic As Object, key As String
   
7.     For i = 2 To Sheets.Count
   
8.         Set sht = Sheets(i)
   
9.         arr = f.GetArrData(sht.[a4], 2, 1, , -2)
   
10.         If IsArray(arr) Then
    
11.             hd.ReadData arr, 1, sht.Name, "工作表名"
    
12.         End If
    
13.     Next
    
14.     arrjg = hd.GetArray
    
15.     For i = 1 To UBound(arrjg)
    
16.         If Trim(arrjg(i, 2)) <> "" Then cRow.Add i
    
17.     Next
    
18.     Set rng = f.Get_range_data([a2], , -1, 1, 0)
    
19.     If Not rng Is Nothing Then rng.ClearContents
    
20.     f.Auto_ArrToRange f.myChooseRows(arrjg, cRow), [a1]
    
21. End Sub

复制代码

cai2532

ykcbf1100 发表于 2025-3-20 18:08

草爷代码越写越上层次。