固定格式的表格汇总

adm0795

lizhipei78 发表于 2025-4-8 09:31
WPS 打开

感谢帮助！

ykcbf1100

参与一下，多表合并

ykcbf1100

1. Sub ykcbf()                 '//2025.4.8
   
2.     Dim tm: tm = Timer
   
3.     Application.ScreenUpdating = False
   
4.     Application.DisplayAlerts = False
   
5.     Set sh = Sheets("汇总")
   
6.     sh.Range("a3:ab10000").ClearContents
   
7.     ReDim brr(1 To 10 ^ 5, 1 To 100)
   
8.     For Each sht In Worksheets
   
9.         If sht.Name <> sh.Name Then
   
10.             With sht
    
11.                 r = .Cells(Rows.Count, 1).End(3).Row
    
12.                 arr = .Range("a1:ab" & r)
    
13.                 fn = .Name
    
14.             End With
    
15.             For i = 3 To UBound(arr)
    
16.                 If arr(i, 1) = Empty Then Exit For
    
17.                 m = m + 1
    
18.                 For j = 1 To UBound(arr, 2)
    
19.                     brr(m, j) = arr(i, j)
    
20.                 Next
    
21.             Next
    
22.         End If
    
23.     Next
    
24.     With sh
    
25.         .Range("a3:ab10000").ClearContents
    
26.         .[a3].Resize(m, UBound(arr, 2)) = brr
    
27.         .[a3].Resize(m, UBound(arr, 2)).Borders.LineStyle = 1
    
28.     End With
    
29.     Application.ScreenUpdating = True
    
30.     MsgBox "汇总完毕，共用时： " & Format(Timer - tm, "0.000秒"), , "提示"
    
31. End Sub
    

复制代码

adm0795

3190496160 发表于 2025-4-8 09:05

感谢帮助！

wang-way

gwjkkkkk

gwjkkkkk

Option Explicit
Sub test1()
    Dim j&, cnn As Object, rst As Object, strSQL$, strFileName$, wks As Worksheet
   
    Application.ScreenUpdating = False
    Set cnn = CreateObject("ADODB.Connection")
   
    strFileName = ThisWorkbook.FullName
    Select Case Application.Version * 1
        Case Is <= 11
            cnn.Open "Provider=Microsoft.JET.OLEDB.4.0;Data Source=" & strFileName & ";Extended Properties='Excel 8.0;HDR=YES;IMEX=0'"
        Case Is >= 12
            cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & strFileName & ";Extended Properties='Excel 12.0;HDR=YES;IMEX=0'"
    End Select
   
    For Each wks In Worksheets
        If wks.Name <> "汇总" Then strSQL = strSQL & " UNION ALL SELECT * FROM [" & wks.Name & "$A2:AB]"
    Next wks
    Set rst = cnn.Execute(Mid(strSQL, 12))
   
    With ThisWorkbook.Sheets("汇总")
        With .Range("A2")
            .CurrentRegion.Clear
            For j = 0 To rst.Fields.Count - 1
                .Offset(, j) = rst.Fields(j).Name
            Next j
            .Offset(1).CopyFromRecordset rst
            .CurrentRegion.EntireColumn.AutoFit
        End With
        .Activate
    End With
   
    rst.Close: cnn.Close
    Set rst = Nothing: Set cnn = Nothing
    Application.ScreenUpdating = True
    Beep
End Sub