Excel自动合并多个工作表数据到一个工作表

zy3333351

请问各位大侠：同一文件夹下有多个工作表，如何自动合并多个工作表数据到一个工作表？（把各个分表粘贴到文件夹内就自动汇总到总表中去了）（我这里只有8个，每个分表中人数也不确定，以后也许会增加更多个工作表）。

谢谢了！！

杨建营

自己动手搜一下，一大堆实例，适当改动就可以用了。

zy3333351

杨建营 发表于 2022-12-7 10:54
自己动手搜一下，一大堆实例，适当改动就可以用了。

我是新手哦，请多关照！！

杨建营

zy3333351 发表于 2022-12-7 10:55
我是新手哦，请多关照！！

我也是，只有自己多操作，不会了再求助，这样对谁都好，是不是？

fzxba

1. Sub test1()
   
2.   Dim p As String
   
3. '  With Application.FileDialog(msoFileDialogFolderPicker)
   
4. '    .InitialFileName = ThisWorkbook.Path
   
5. '    If .Show Then p = .SelectedItems(1) Else Exit Sub
   
6. '  End With
   
7. '  If Right(p, 1) <> "\" Then p = p & "\"
   
8.   
   
9.   Range("A2:G" & Rows.Count).ClearContents
   
10.   Application.ScreenUpdating = False
    
11.   
    
12.   Dim Conn As Object, rs As Object, Target As Range, Dict As Object
    
13.   Dim strConn As String, SQL As String, f As String, s As String ' p As String,
    
14.   Dim Flag As Boolean, i As Integer
    
15.   
    
16.   Set Target = Range("A3")
    
17.   Set Dict = CreateObject("Scripting.Dictionary")
    
18.   Set Conn = CreateObject("ADODB.Connection")
    
19.   
    
20.   s = "Excel 12.0;HDR=yes;Database="
    
21.   If Application.Version < 12 Then
    
22.     s = Replace(s, "12.0", "8.0")
    
23.     strConn = "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties=Excel 8.0;Data Source="
    
24.   Else
    
25.     strConn = "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source="
    
26.   End If
    
27.   Conn.Open strConn & ThisWorkbook.FullName
    
28.   
    
29.   p = ThisWorkbook.Path & "\"
    
30.   f = Dir(p & "*.xls?")
    
31.     SQL = "SELECT * FROM [" & s & p & "[f]].[$A2:G] WHERE "
    
32.   
    
33.   While Len(f)
    
34.     If p & f <> ThisWorkbook.FullName Then
    
35.       If Not Flag Then
    
36.         Set rs = Conn.Execute(Replace(SQL, "[f]", f) & "FALSE")
    
37.         For i = 0 To rs.Fields.Count - 1
    
38.           If Not rs.Fields(i).Name Like "F[1-9]*" Then Range("A2").Offset(0, i) = rs.Fields(i).Name
    
39.         Next
    
40.         Set rs = Nothing
    
41.         Flag = True
    
42.       End If
    
43.       Dict.Add Replace(SQL, "[f]", f) & "LEN(姓名)", vbNullString
    
44.       If Dict.Count Mod 49 = 0 Then
    
45.         Target.CopyFromRecordset Conn.Execute(Join(Dict.Keys, " UNION ALL "))
    
46.         Set Target = Cells(Rows.Count, "A").End(xlUp).Offset(1)
    
47.         Dict.RemoveAll
    
48.       End If
    
49.     End If
    
50.     f = Dir
    
51.   Wend
    
52.   If Dict.Count Then Target.CopyFromRecordset Conn.Execute(Join(Dict.Keys, " UNION ALL "))
    
53.   
    
54.   Conn.Close
    
55.   Set Conn = Nothing
    
56.   Set Target = Nothing
    
57.   Set Dict = Nothing
    
58.   Application.ScreenUpdating = True
    
59.   Beep
    
60. End Sub

复制代码

fzxba

学生成绩统计.rar (92.01 KB, 下载次数: 47)

2022-12-7 11:26 上传

点击文件名下载附件

3190496160

这个合并工具完全能够满足你的需求，没必要再写代码了，
合并工具-Excel VBA程序开发-ExcelHome技术论坛 -  https://club.excelhome.net/thread-1639995-1-1.html

熊文来

3190496160 发表于 2022-12-7 11:30
这个合并工具完全能够满足你的需求，没必要再写代码了，
合并工具-Excel VBA程序开发-ExcelHome技术论坛 - ...

确实很好  有需要的就来用。

zy3333351

感谢楼主分享，谢谢！！

ykcbf1100

多工作簿合并、总分计算、排序、排名