按照标题字段汇集所选定文件件里的所有工作簿

wowo000

论坛里的各位老师：早上好！劳烦斧正附件里的代码使其符合里面所表述的要求（现有代码只能选一个簿导一个簿，请改成选定某文件将其所有簿一次性导入），谢谢！

shiruiqiang

说实话，改别人的代码比自己写还比较麻烦。
练个手吧，不包售后

ykcbf1100

还是新写一个吧，没有多大修改的意义。

ykcbf1100

参与一下。。。

1. Sub ykcbf()  '//2024.4.6
   
2.     Application.ScreenUpdating = False
   
3.     Application.AskToUpdateLinks = False
   
4.     Application.DisplayAlerts = False
   
5.     Dim tm: tm = Timer
   
6.     Set fso = CreateObject("Scripting.FileSystemObject")
   
7.     Set d = CreateObject("Scripting.Dictionary")
   
8.     Set sh = ThisWorkbook.Sheets("汇集表")
   
9.     With sh
   
10.         c = .UsedRange.Columns.Count
    
11.         arr = .[a1].Resize(1, c)
    
12.     End With
    
13.     For j = 1 To UBound(arr, 2)
    
14.         If arr(1, j) <> Empty Then
    
15.             s = arr(1, j)
    
16.             d(s) = j
    
17.         End If
    
18.     Next
    
19.     ReDim brr(1 To 10000, 1 To 100)
    
20.     With Application.FileDialog(msoFileDialogFolderPicker)
    
21.         .Title = "请选择文件夹"
    
22.         .InitialFileName = ThisWorkbook.Path & ""
    
23.         If .Show = -1 Then
    
24.             p = .SelectedItems(1) & ""
    
25.         End If
    
26.     End With
    
27.     For Each f In fso.GetFolder(p).Files
    
28.         If f.Name Like "*.xls*" Then
    
29.             If InStr(f.Name, ThisWorkbook.Name) = 0 Then
    
30.                 fn = fso.GetBaseName(f)
    
31.                 Set wb = Workbooks.Open(f, 0)
    
32.                 With wb.Sheets(1)
    
33.                     .AutoFilterMode = False
    
34.                     arr = .UsedRange
    
35.                     wb.Close False
    
36.                 End With
    
37.                 For i = 2 To UBound(arr)
    
38.                     If arr(i, 1) <> Empty Then
    
39.                         m = m + 1
    
40.                         For j = 1 To UBound(arr, 2)
    
41.                             s = arr(1, j)
    
42.                             If s <> Empty Then
    
43.                                 If Not d.exists(s) Then
    
44.                                     d(s) = d.Count
    
45.                                 End If
    
46.                                 brr(m, d(s)) = arr(i, j)
    
47.                             End If
    
48.                         Next
    
49.                     End If
    
50.                 Next
    
51.             End If
    
52.         End If
    
53.     Next f
    
54.     With sh
    
55.         .UsedRange.Clear
    
56.         .[a1].Resize(1, d.Count) = d.keys
    
57.         .[a1].Resize(1, d.Count).Interior.Color = 49407
    
58.         If m Then
    
59.             .[a2].Resize(m, d.Count) = brr
    
60.             .Range("A1").Resize(m + 1, d.Count).Borders.LineStyle = 1
    
61.         End If
    
62.     End With
    
63.     Set d = Nothing
    
64.     Application.ScreenUpdating = True
    
65.     Application.AskToUpdateLinks = True
    
66.     Application.DisplayAlerts = True
    
67.     MsgBox "共用时：" & Format(Timer - tm) & "秒！"
    
68. End Sub
    

复制代码

baofa2

测试.zip (51.87 KB, 下载次数: 20)

2024-4-6 09:20 上传

点击文件名下载附件

shiruiqiang

baofa2 发表于 2024-4-6 09:21

老师，请教一下，如果是这种情况，用sql汇总，需要增加字段怎么处理？谢谢

baofa2

shiruiqiang 发表于 2024-4-6 09:36
老师，请教一下，如果是这种情况，用sql汇总，需要增加字段怎么处理？谢谢

1. Sub test2() '给你写个，仅供你参考
   
2.   
   
3.   Dim dict(1) As New Dictionary
   
4.   Dim Conn As New ADODB.Connection
   
5.   Dim rs As New ADODB.Recordset
   
6.   
   
7.   Dim ar, br, i As Integer
   
8.   Dim strSQL(1) As String, strConn As String, strField As String
   
9.   Dim s As String, p As String, f As String
   
10.   'Const adStateOpen As Long = 1
    
11.   'Const adOpenKeyset As Long = 1
    
12.   'Const adLockOptimistic As Long = 3
    
13.   
    
14.   Rows("2:" & Rows.Count).ClearContents
    
15.   Application.ScreenUpdating = False
    
16.   
    
17.   s = "Excel 12.0;HDR=YES;Database="
    
18.   If Application.Version < 12 Then
    
19.     s = Replace(s, "12.0", "8.0")
    
20.     strConn = "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties='Excel 8.0;HDR=YES';Data Source="
    
21.   Else
    
22.     strConn = "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties='Excel 12.0;HDR=YES';Data Source="
    
23.   End If
    
24.   Conn.Open strConn & ThisWorkbook.FullName
    
25.   
    
26.   p = ThisWorkbook.Path & "\数据文件夹\"
    
27.   f = Dir(p & "*.xls*")
    
28.   Do
    
29.     If p & f <> ThisWorkbook.FullName Then
    
30.       strSQL(0) = "SELECT * FROM [" & s & p & f & "].[$A1:Z1] WHERE FALSE"
    
31.       Set rs = Conn.Execute(strSQL(0))
    
32.       For i = 0 To rs.Fields.Count - 1
    
33.         strField = rs.Fields(i).Name
    
34.         If Not strField Like "F[1-9]*" Then
    
35.           strField = "`" & strField & "`"
    
36.           If Not dict(0).Exists(strField) Then dict(0).Add strField, dict(0).Count
    
37.         End If
    
38.       Next
    
39.     End If
    
40.     f = Dir
    
41.   Loop While f <> ""
    
42.   
    
43.   br = dict(0).Keys
    
44.   For i = LBound(br) To UBound(br)
    
45.     br(i) = "NULL AS " & br(i)
    
46.   Next
    
47.   
    
48.   f = Dir(p & "*.xls*")
    
49.   Do
    
50.     If p & f <> ThisWorkbook.FullName Then
    
51.       strSQL(0) = "SELECT * FROM [" & s & p & f & "].[$A1:Z1] WHERE FALSE"
    
52.       strSQL(1) = "SELECT [.Fields] FROM [" & s & p & f & "].[$A1:Z]"
    
53.       ar = br
    
54.       Set rs = Conn.Execute(strSQL(0))
    
55.       For i = 0 To rs.Fields.Count - 1
    
56.         strField = "`" & rs.Fields(i).Name & "`"
    
57.         If dict(0).Exists(strField) Then ar(dict(0)(strField)) = strField
    
58.       Next
    
59.       dict(1).Add Replace(strSQL(1), "[.Fields]", Join(ar, ",")), ""
    
60.     End If
    
61.     f = Dir
    
62.   Loop While f <> ""
    
63.   
    
64.   If rs.State = adStateOpen Then rs.Close
    
65.   rs.Open Join(dict(1).Keys, " UNION ALL "), Conn, adOpenKeyset, adLockOptimistic
    
66.   
    
67.   With Range("A3")
    
68.     For i = 0 To rs.Fields.Count - 1
    
69.       .Offset(0, i) = rs.Fields(i).Name
    
70.     Next
    
71.     .Offset(1).CopyFromRecordset rs
    
72. '    With .CurrentRegion
    
73. '      .Font.Name = "微软雅黑"
    
74. '      .Font.Size = 11
    
75. '      .Rows(1).Font.Bold = True
    
76. '      .HorizontalAlignment = xlCenter
    
77. '      .Borders.LineStyle = xlContinuous
    
78. '    End With
    
79.   End With
    
80.   
    
81.   If rs.State = adStateOpen Then rs.Close
    
82.   Set rs = Nothing
    
83.   If Conn.State = adStateOpen Then Conn.Close
    
84.   Set Conn = Nothing
    
85.   For i = 0 To UBound(dict)
    
86.     Set dict(i) = Nothing
    
87.   Next
    
88.   
    
89.   Application.ScreenUpdating = True
    
90.   Beep
    
91. End Sub

复制代码

jjmysjg

ykcbf1100 发表于 2024-4-6 09:06
还是新写一个吧，没有多大修改的意义。

大侠：如果想导入各簿的所有表，怎么修改代码？
谢谢大侠！

ykcbf1100

jjmysjg 发表于 2024-4-6 09:59
大侠：如果想导入各簿的所有表，怎么修改代码？
谢谢大侠！

再加个表循环

wowo000

尊敬的baofa2老师和shiruiqiang老师及ykcbf1100老师：假如“汇集表”第一行的标题字段用VBA代码自动生成咋整？？劳烦赐教，多谢！！！