万帖成专家之合并

LMY123

目录
1   同薄多表
2   同夹-多薄
3   单级-多夹
4   多级-多夹
5   同名工作表
6   同名工作薄
7   同类工作表
8   同类工作薄
9   BAT合并多个文本文件
10 合并PDF
11 合并WORD

LMY123

1. 'http://club.excelhome.net/forum.php?mod=viewthread&tid=1271861
   
2. Sub 单级_单夹_多薄_指定表_合并成一薄一表_ADO法()
   
3.     Dim 连接 As ADODB.Connection: Dim 记录 As ADODB.Recordset
   
4.     Dim Fso As Object, 外薄 As Object
   
5.     Set Fso = CreateObject("Scripting.FileSystemObject")
   
6.     Cells.Clear
   
7.     路径 = ThisWorkbook.Path & "\初一年级"
   
8.     myPath = InputBox("请输入要查询工作簿的文件夹完整目录及名字：" _
   
9.         & vbCrLf & vbCrLf & "如果为空，则默认为" & vbCrLf _
   
10.         & 路径, "输入路径", 路径)
    
11.     If myPath = "" Then myPath = 路径
    
12.     Application.StatusBar = "正在查找汇总工作簿......"
    
13.     外薄个数 = Fso.GetFolder(myPath).Files.Count
    
14.     If 外薄个数 > 0 Then
    
15.         MsgBox "在此文件夹中共有 " & 外薄个数 & " 个工作表的数据文件需要汇总！", _
    
16.             vbInformation, "搜索到汇总文件"
    
17.         ReDim 外薄数组(1 To 外薄个数) As String
    
18.         For Each 外薄 In Fso.GetFolder(myPath).Files
    
19.             计数器 = 计数器 + 1
    
20.             外薄数组(计数器) = 外薄
    
21.         Next
    
22.     Else
    
23.         MsgBox "没有搜索到要汇总的文件！", vbInformation, "没有汇总文件"
    
24.         Application.StatusBar = False
    
25.         Exit Sub
    
26.     End If
    
27.     For i = 1 To 外薄个数
    
28.         Set 连接 = New ADODB.Connection
    
29.         With 连接
    
30.             .Provider = "microsoft.jet.oledb.4.0"
    
31.             .ConnectionString = "Extended Properties=Excel 8.0;" _
    
32.                 & "Data Source=" & 外薄数组(i)
    
33.             .Open
    
34.         End With
    
35.         Set 记录 = New ADODB.Recordset
    
36.         SQL = "select * from [Sheet1$]"
    
37.         记录.Open SQL, 连接, adOpenKeyset, adLockOptimistic
    
38.         If i = 1 Then        '复制字段名称到"原始数据汇总"工作表
    
39.             For 列 = 0 To 记录.Fields.Count - 1
    
40.                 Cells(1, 列 + 1) = 记录.Fields(列).Name
    
41.             Next 列
    
42.         End If
    
43.         n = Range("A65536").End(xlUp).Row
    
44.         If 记录.RecordCount <> 0 Then
    
45.             Range("A" & n + 1).CopyFromRecordset 记录
    
46.         End If
    
47.     Next i
    
48.     Application.StatusBar = False
    
49.     MsgBox "工作簿汇总完毕！共汇总了 " & 外薄个数 & " 个工作簿。", vbInformation, "汇总完毕"
    
50.     记录.Close: Set 记录 = Nothing
    
51.     连接.Close: Set 连接 = Nothing
    
52. End Sub

复制代码

LMY123

1. 'http://club.excelhome.net/thread-1281113-2-1.html
   
2. Sub 同名工作薄_分别合并成一薄一表_ADO加字典法() '''已入代码宝库
   
3.     Dim 字典 As Object
   
4.     Application.ScreenUpdating = False: Application.DisplayAlerts = False
   
5.     Set 字典 = CreateObject("scripting.dictionary")
   
6.     Set 连接 = CreateObject("adodb.connection")
   
7.     Set Fso = CreateObject("Scripting.FileSystemObject")
   
8.     Set Folder = Fso.GetFolder(ThisWorkbook.Path & "\数据")
   
9.     Call 子程序(Folder, 字典)
   
10.     Set 新生薄 = Workbooks.Add(xlWBATWorksheet)
    
11.     连接.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=excel 12.0;Data Source=" & ThisWorkbook.FullName
    
12.     关键字 = 字典.keys
    
13.     项 = 字典.items
    
14.     For i = 0 To 字典.Count - 1
    
15.         项拆分数组 = Split(项(i), ",")
    
16.         With 新生薄.Sheets(1)
    
17.             .Cells.ClearContents
    
18.             For j = 0 To UBound(项拆分数组)
    
19.                 SQL = "select * from [Excel 12.0;Database=" & 项拆分数组(i) & "].[Sheet1$]"
    
20.                 Set 记录 = 连接.Execute(SQL)
    
21.                 If j = 0 Then
    
22.                     For 列 = 1 To 记录.Fields.Count
    
23.                         .Cells(1, 列) = 记录.Fields(列 - 1).Name
    
24.                     Next
    
25.                     .[a2].CopyFromRecordset 记录
    
26.                 Else
    
27.                     .Range("a" & .Rows.Count).End(xlUp).Offset(1).CopyFromRecordset 连接.Execute(SQL)
    
28.                 End If
    
29.             Next
    
30.             新生薄.SaveAs ThisWorkbook.Path & "\需要得到的结果" & 关键字(i)
    
31.         End With
    
32.     Next
    
33.     新生薄.Close
    
34.     Set Folder = Nothing
    
35.     Set Fso = Nothing
    
36.     记录.Close: Set 记录 = Nothing
    
37.     连接.Close: Set 连接 = Nothing
    
38.     Application.ScreenUpdating = True
    
39.     MsgBox "ok"
    
40. End Sub
    
41. Sub 子程序(ByVal Folder As Object, 字典 As Object)
    
42.     Dim SubFolder As Object
    
43.     Dim 外薄 As Object
    
44.     For Each 外薄 In Folder.Files
    
45.         If 外薄.Name Like "*.xlsx" Then
    
46.             If Not 字典.Exists(外薄.Name) Then
    
47.                 字典(外薄.Name) = 外薄
    
48.             Else
    
49.                 字典(外薄.Name) = 字典(外薄.Name) & "," & 外薄
    
50.             End If
    
51.         End If
    
52.     Next
    
53.     For Each SubFolder In Folder.SubFolders
    
54.         Call 子程序(SubFolder, 字典)
    
55.     Next
    
56. End Sub
    
57. Sub 同类工作薄_分别合并成一薄一表_ADO加字典法() '''已入代码宝库
    
58.     Dim 字典 As Object
    
59.     Application.ScreenUpdating = False: Application.DisplayAlerts = False
    
60.     Set 字典 = CreateObject("scripting.dictionary")
    
61.     Set 连接 = CreateObject("adodb.connection")
    
62.     Set Fso = CreateObject("Scripting.FileSystemObject")
    
63.     Set Folder = Fso.GetFolder(ThisWorkbook.Path & "\数据")
    
64.     Call 内程序(Folder, 字典)
    
65.     Set 新生薄 = Workbooks.Add(xlWBATWorksheet)
    
66.     连接.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=excel 12.0;Data Source=" & ThisWorkbook.FullName
    
67.     关键字 = 字典.keys
    
68.     项 = 字典.items
    
69.     For i = 0 To 字典.Count - 1
    
70.         项拆分数组 = Split(项(i), ",")
    
71.         With 新生薄.Sheets(1)
    
72.             .Cells.ClearContents
    
73.             For j = 0 To UBound(项拆分数组)
    
74.                 SQL = "select * from [Excel 12.0;Database=" & ThisWorkbook.Path & "\数据" & 项拆分数组(j) & "].[Sheet1$]"
    
75.                 Set 记录 = 连接.Execute(SQL)
    
76.                 If j = 0 Then
    
77.                     For 列 = 1 To 记录.Fields.Count
    
78.                         .Cells(1, 列) = 记录.Fields(列 - 1).Name
    
79.                     Next
    
80.                     .[a2].CopyFromRecordset 记录
    
81.                 Else
    
82.                     .Range("a" & .Rows.Count).End(xlUp).Offset(1).CopyFromRecordset 连接.Execute(SQL)
    
83.                 End If
    
84.             Next
    
85.             新生薄.SaveAs ThisWorkbook.Path & "" & 关键字(i)
    
86.         End With
    
87.     Next
    
88.     新生薄.Close
    
89.     Set Folder = Nothing
    
90.     Set Fso = Nothing
    
91.     记录.Close: Set 记录 = Nothing
    
92.     连接.Close: Set 连接 = Nothing
    
93.     Application.ScreenUpdating = True
    
94.     MsgBox "ok"
    
95. End Sub
    
96. Sub 内程序(ByVal Folder As Object, 字典 As Object)
    
97.     Dim SubFolder As Object
    
98.     Dim 外薄 As Object
    
99.     For Each 外薄 In Folder.Files
    
100.         If 外薄.Name Like "*.xlsx" Then
     
101.             If Not 字典.Exists(Split(外薄.Name, " ")(0)) Then
     
102.                 字典(Split(外薄.Name, " ")(0)) = 外薄.Name
     
103.             Else
     
104.                 字典(Split(外薄.Name, " ")(0)) = 字典(Split(外薄.Name, " ")(0)) & "," & 外薄.Name
     
105.             End If
     
106.         End If
     
107.     Next
     
108. End Sub

复制代码

LMY123

1. 'http://club.excelhome.net/forum.php?mod=viewthread&tid=1449499
   
2. Sub 同薄多表合并_ADO() '''已入代码宝库
   
3.     Cells.Clear
   
4.     t = Timer
   
5.     Set 连接 = CreateObject("adodb.connection")
   
6.     工作表个数 = ThisWorkbook.Sheets.Count
   
7.     连接.Open "provider=microsoft.ace.oledb.12.0;extended properties='Excel 12.0;hdr=NO';data source=" & ThisWorkbook.FullName
   
8.     For i = 1 To 工作表个数 - 1
   
9.         If Len(Sql) Then Sql = Sql & " union all "
   
10.         Sql = Sql & "select * from [" & ThisWorkbook.Sheets(i).Name & "$A1:al]where F2 is not null "
    
11.     Next
    
12.     If Len(Sql) Then Worksheets("合并后").[a1048576].End(xlUp).Offset(1).CopyFromRecordset 连接.Execute(Sql)
    
13.     连接.Close
    
14.     Set 连接 = Nothing
    
15.     MsgBox "汇总完毕！共用时" & Format(Timer - t, "0.0000") & "秒", vbInformation, "信息提示"
    
16. End Sub

复制代码

kszcs

大侠，上个附件好吧

我有二哈和酒

LMY123 发表于 2018-12-24 10:46

楼主大大，提示用户类型未定义

cui26896

LMY123 发表于 2018-12-24 10:46

老师的这个是向下单元格汇总，我向老师发附件的是向右边的单元格汇总。