多个sheet页 汇总

orange8765

各位老师：如何将多个sheet页汇总呢

shiruiqiang

看了一下，湖州的表格不规范，改成[a2:q1000]吧

gwjkkkkk

Option Explicit
Sub TEST2()
    Dim ar, br, i&, j&, r&, n&, wks As Worksheet, iStart&
   
    Application.ScreenUpdating = False
   
    For Each wks In Worksheets
        If wks.Name <> "汇总表" Then
            ar = wks.[A1].CurrentRegion.Value
            If IsArray(ar) Then
                n = n + 1
                If n = 1 Then
                    ReDim br(1 To 10 ^ 3, 1 To UBound(ar, 2))
                    iStart = 1
                Else
                    iStart = 2
                End If
                For i = iStart To UBound(ar)
                    r = r + 1
                    For j = 1 To UBound(br, 2)
                        br(r, j) = ar(i, j)
                    Next j
                Next i
            End If
        End If
    Next
    With Worksheets("汇总表")
        .Cells.Clear
        With .[A1].Resize(r, UBound(br, 2))
            .Value = br
            .HorizontalAlignment = xlCenter
            .VerticalAlignment = xlCenter
            .Borders.LineStyle = xlContinuous
        End With
        .Activate
    End With
    Application.ScreenUpdating = True
    Beep
End Sub

gwjkkkkk

数组法，参与一下。。。

ykcbf1100

附件供参考。。。

ykcbf1100

参与一下。。。

1. Sub 多表合并()  '//2024.2.21
   
2.     Application.ScreenUpdating = False
   
3.     Set sh = ThisWorkbook.Sheets("汇总表")
   
4.     sh.UsedRange.Clear
   
5.     On Error Resume Next
   
6.     For Each sht In Sheets
   
7.         If sht.Name <> sh.Name Then
   
8.             With sht
   
9.                 arr = .UsedRange
   
10.                 If IsArray(sht.UsedRange) Then
    
11.                     m = m + 1
    
12.                     If m = 1 Then
    
13.                         .UsedRange.Copy sh.Cells(1, 1)
    
14.                     Else
    
15.                         r = sh.Cells(sh.Rows.Count, 2).End(3).Offset(1).Row
    
16.                         .UsedRange.Offset(2).Copy sh.Cells(r, 1)
    
17.                     End If
    
18.                 End If
    
19.             End With
    
20.         End If
    
21.     Next
    
22.     With sh
    
23.         With .UsedRange
    
24.             .Borders.LineStyle = 1
    
25.             .HorizontalAlignment = xlCenter
    
26.             .VerticalAlignment = xlCenter
    
27.             .EntireColumn.AutoFit
    
28.         End With
    
29.     End With
    
30.     Application.ScreenUpdating = True
    
31.     MsgBox "OK！"
    
32. End Sub
    

复制代码

dixuan0329

shiruiqiang 发表于 2024-2-21 18:04
看了一下，湖州的表格不规范，改成[a2:q1000]吧

学习了，老师的方法通俗易懂