多表数据汇总，谢谢！

ykcbf1100

闲着也是闲着，练个手吧。多表合并，除汇总表外的所有表合并。
此题因为分表中有跨表公式，不太适合直接用copy法，改用数组法，速度还快。

ykcbf1100

练手，除汇总表外的所有表合并，数组法

1. Sub ykcbf()  '//2024.6.26   除汇总表外的所有表合并,数组法(因分表中有跨表公式,不太适合用copy法)
   
2.     Application.ScreenUpdating = False
   
3.     Set sh = ThisWorkbook.Sheets("汇总")
   
4.     ReDim brr(1 To 100000, 1 To 100)
   
5.     For Each sht In Sheets
   
6.         If sht.Name <> sh.Name Then
   
7.             arr = sht.UsedRange
   
8.             If UBound(arr) > 1 Then
   
9.                 For i = 4 To UBound(arr)
   
10.                     If arr(i, 1) <> Empty Then
    
11.                         m = m + 1
    
12.                         brr(m, 1) = m
    
13.                         For j = 2 To UBound(arr, 2)
    
14.                             brr(m, j) = arr(i, j)
    
15.                         Next
    
16.                     End If
    
17.                 Next
    
18.             End If
    
19.         End If
    
20.     Next
    
21.     With sh
    
22.         .UsedRange.Offset(1).Clear
    
23.         With .[a2].Resize(m, 10)
    
24.             .Value = brr
    
25.             .Borders.LineStyle = 1
    
26.             .HorizontalAlignment = xlCenter
    
27.             .VerticalAlignment = xlCenter
    
28.         End With
    
29.     End With
    
30.     Application.ScreenUpdating = True
    
31.     MsgBox "OK！"
    
32. End Sub
    
33. 
    

复制代码

ykcbf1100

练手，合并汇总表左边的所有表

ykcbf1100

合并汇总表左边的所有表

1. Sub ykcbf()  '//2024.6.26   多表合并,数组法(只合并汇总表左边的表)
   
2.     Application.ScreenUpdating = False
   
3.     Set ws = ThisWorkbook
   
4.     Set sh = ws.Sheets("汇总")
   
5.     ReDim brr(1 To 100000, 1 To 100)
   
6.     For x = 1 To sh.Index - 1
   
7.         arr = ws.Sheets(x).UsedRange
   
8.         If UBound(arr) > 1 Then
   
9.             For i = 4 To UBound(arr)
   
10.                 If arr(i, 1) <> Empty Then
    
11.                     m = m + 1
    
12.                     brr(m, 1) = m
    
13.                     For j = 2 To UBound(arr, 2)
    
14.                         brr(m, j) = arr(i, j)
    
15.                     Next
    
16.                 End If
    
17.             Next
    
18.         End If
    
19.     Next
    
20.     With sh
    
21.         .UsedRange.Offset(1).Clear
    
22.         With .[a2].Resize(m, 10)
    
23.             .Value = brr
    
24.             .Borders.LineStyle = 1
    
25.             .HorizontalAlignment = xlCenter
    
26.             .VerticalAlignment = xlCenter
    
27.         End With
    
28.     End With
    
29.     Application.ScreenUpdating = True
    
30.     MsgBox "OK！"
    
31. End Sub
    

复制代码