多工作簿内的工作表合并

枫丹白露

求大神给段代码，谢谢

    在同一个文件夹内，100个工作表，是班级花名册，工作表名称规律为“班级1，班级2......”，
   工作表文件夹路径为 D:\班级\花名册



    如何将这100个工作表中的花名册中 B5:M60 的内容合并到一个工作表里【该文件夹已有工作表，名为《总表》】？



见附件

ykcbf1100

附件呢？     

不会是想让写代码的人给你摸拟附件吧

枫丹白露

ykcbf1100 发表于 2025-3-13 14:48
附件呢？     

不会是想让写代码的人给你摸拟附件吧

sorry,我原想着不能传整个文件夹上，现在知道了，马上传个表

枫丹白露

附件上传了，请大神帮助

ykcbf1100

枫丹白露 发表于 2025-3-13 16:12
附件上传了，请大神帮助

你100个工作簿不传，传一个上来总可以吧。啥都没有，代码写起来也没法测试的

枫丹白露

ykcbf1100 发表于 2025-3-13 16:25
你100个工作簿不传，传一个上来总可以吧。啥都没有，代码写起来也没法测试的

谢谢指点，我没有想到文件包压缩，谢谢。已经传好，请帮我看一下

baofa2

1. Sub test0()
   
2.   
   
3.   Dim conn As Object, dict As Object, target As Range
   
4.   Dim strConn As String, strPath As String, strFile As String, s As String
   
5.   
   
6.   Sheet1.Activate
   
7.   ActiveSheet.UsedRange.Offset(4, 1).ClearContents
   
8.   Application.ScreenUpdating = False
   
9.   
   
10.   s = "Excel 12.0;HDR=YES;Database="
    
11.   If Application.Version < 12 Then
    
12.     strConn = "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties=Excel 8.0;Data Source="
    
13.     s = Replace(s, "12.0", "8.0")
    
14.   Else
    
15.     strConn = "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source="
    
16.   End If
    
17.   
    
18.   Set target = Range("B5")
    
19.   Set dict = CreateObject("Scripting.Dictionary")
    
20.   Set conn = CreateObject("ADODB.Connection")
    
21.   conn.Open strConn & ThisWorkbook.FullName
    
22.   
    
23.   strPath = ThisWorkbook.Path & "\"
    
24.   strFile = Dir(strPath & "*.xls*")
    
25.   
    
26.   While Len(strFile)
    
27.     If strPath & strFile <> ThisWorkbook.FullName Then
    
28.       dict.Add "SELECT * FROM [" & s & strPath & strFile & "].[$B4:M60] WHERE 姓名 IS NOT NULL", ""
    
29.       If dict.Count = 49 Then
    
30.         target.CopyFromRecordset conn.Execute(Join(dict.Keys, " UNION ALL "))
    
31.         Set target = Cells(Rows.Count, "B").End(xlUp).Offset(1)
    
32.         dict.RemoveAll
    
33.       End If
    
34.     End If
    
35.     strFile = Dir
    
36.   Wend
    
37.   
    
38.   If dict.Count Then target.CopyFromRecordset conn.Execute(Join(dict.Keys, " UNION ALL "))
    
39.   
    
40.   conn.Close
    
41.   Set conn = Nothing
    
42.   Set target = Nothing
    
43.   Set dict = Nothing
    
44.   
    
45.   Application.ScreenUpdating = True
    
46.   Beep
    
47. End Sub
    

复制代码

ykcbf1100

附件供参考，原则上工作簿可以有很多

ykcbf1100

1. Sub ykcbf()   '//2025.3.13
   
2.     Application.ScreenUpdating = False
   
3.     Set fso = CreateObject("scripting.filesystemobject")
   
4.     Set ws = ThisWorkbook
   
5.     p = ws.Path & ""
   
6.     Set Sh = ThisWorkbook.Sheets("总表")
   
7.     On Error Resume Next
   
8.     Dim tm: tm = Timer
   
9.     ReDim brr(1 To 10 ^ 5, 1 To 100)
   
10.     For Each f In fso.GetFolder(p).Files
    
11.         If LCase$(f.Name) Like "*.xls*" Then
    
12.             If InStr(f.Name, ThisWorkbook.Name) = 0 Then
    
13.                 fn = fso.GetBaseName(f)
    
14.                 Set wb = Workbooks.Open(f, 0)
    
15.                 arr = wb.Sheets("班级的样表").UsedRange
    
16.                 wb.Close 0
    
17.                 For i = 5 To UBound(arr)
    
18.                     If arr(i, 1) * 1 Then
    
19.                         m = m + 1
    
20.                         brr(m, 1) = m
    
21.                         For j = 2 To UBound(arr, 2)
    
22.                             brr(m, j) = arr(i, j)
    
23.                         Next
    
24.                     End If
    
25.                 Next
    
26.             End If
    
27.         End If
    
28.     Next
    
29.     With Sh
    
30.         .UsedRange.Offset(4) = Empty
    
31.         .[a5].Resize(m, 14) = brr
    
32.         .[a5].Resize(m, 14).Borders.LineStyle = 1
    
33.     End With
    
34.     Application.ScreenUpdating = True
    
35.     MsgBox "共用时：" & Format(Timer - tm, "0.000") & "秒！"
    
36. End Sub
    

复制代码

gwjkkkkk

Option Explicit
Sub test1()
    Dim ar, i&, j&, cnn As Object, rst As Object, strSQL$, strCnn$, strJoin$, strPath$, strFileName$
   
    Application.ScreenUpdating = False
   
    strJoin = "Excel 12.0;HDR=YES;IMEX=0;Database="
    Select Case Application.Version * 1
        Case Is <= 11
            strJoin = Replace(strJoin, "12.0;", "8.0;")
            strCnn = "Provider=Microsoft.JET.OLEDB.4.0;Data Source=" & ThisWorkbook.FullName & ";Extended Properties='Excel 8.0;HDR=YES;IMEX=0'"
        Case Is >= 12
            strCnn = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ThisWorkbook.FullName & ";Extended Properties='Excel 12.0;HDR=YES;IMEX=0'"
    End Select

    strPath = ThisWorkbook.Path & "\"
    strFileName = Dir(strPath & "*.xls")
    Do Until strFileName = ""
        If strFileName <> ThisWorkbook.Name Then
            strSQL = strSQL & " UNION ALL SELECT * FROM [" & strJoin & strPath & strFileName & "].[$A4:M] WHERE 年级 IS NOT NULL"
        End If
        strFileName = Dir
    Loop
   
    If Len(strSQL) = 0 Then
        Application.ScreenUpdating = True: MsgBox "未找到待汇总文件!", vbCritical: Exit Sub
    Else
        strSQL = Mid(strSQL, 12)
    End If
        
    Set cnn = CreateObject("ADODB.Connection")
    cnn.Open strCnn
    Set rst = cnn.Execute(strSQL)
   
    With ThisWorkbook.Sheets(1)
        .[A5].CopyFromRecordset rst
        With .[A4].CurrentRegion
                ar = .Columns(1).Value
                If IsArray(ar) Then
                    For i = 2 To UBound(ar)
                        ar(i, 1) = i - 1
                    Next i
                    .Columns(1).Value = ar
                End If
            End With
        .Activate
    End With
   
    rst.Close: cnn.Close
    Set rst = Nothing: Set cnn = Nothing
    Application.ScreenUpdating = True
    Beep
End Sub