多个工作簿中的某一个指定sheet内容汇总

小马哥66

各位大神，


来求助一下！
我日常工作中，有多个工作簿（每次约200个）需要汇总，规则如下。
1. 工作簿的结构完全一致
2. 待合并的工作簿全部在一个文件夹内
3. 合并时，需要让我来选择‘待合并文件夹’（每次都不一样，所以，每次需要我自己来选择）
4. 汇总的内容，另存为一个工作簿，保存在桌面，名称为“汇总表-yyyy-mm-dd”
5. 待合并的内容为Sheet名称为“基本信息&商品信息”A22：AP（直至最后有数据的一行，每个工作簿的合并行数不固定）
6.在汇总表的AQ1写入“企业内部编号”，并将每个文件名称的编号写入，如：企业明细导出数据E20200001261311939，仅写入“E20200001261311939”

我做了模拟数据，请各位帮忙，感谢！

ykcbf1100

代码更新一下，增加工作簿另存功能。

ykcbf1100

参与一下。。。

1. Sub ykcbf()  '//2024.5.22  多工作簿合并
   
2.     Set fso = CreateObject("scripting.filesystemobject")
   
3.     Application.ScreenUpdating = False
   
4.     Dim tm: tm = Timer
   
5.     Set sh = ThisWorkbook.Sheets("汇总表")
   
6.     p1 = CreateObject("Wscript.Shell").SpecialFolders("Desktop")
   
7.     With Application.FileDialog(msoFileDialogFolderPicker)
   
8.         .Title = "请选择文件夹"
   
9.         .InitialFileName = ThisWorkbook.Path & ""
   
10.         If .Show = -1 Then
    
11.             p = .SelectedItems(1) & ""
    
12.         End If
    
13.     End With
    
14.     ReDim brr(1 To 100000, 1 To 100)
    
15.     For Each f In fso.GetFolder(p).Files
    
16.         If f.Name Like "*.xls*" Then
    
17.             If InStr(f.Name, ThisWorkbook.Name) = 0 Then
    
18.                 fn = fso.GetBaseName(f)
    
19.                 Set wb = Workbooks.Open(f, 0)
    
20.                 With wb.Sheets("基本信息&商品信息")
    
21.                     r = .Cells(Rows.Count, 1).End(3).Row
    
22.                     arr = .UsedRange
    
23.                     wb.Close False
    
24.                 End With
    
25.                 For i = 23 To UBound(arr)
    
26.                     If Val(arr(i, 1)) Then
    
27.                         m = m + 1
    
28.                         brr(m, 1) = m
    
29.                         For j = 2 To UBound(arr, 2)
    
30.                             brr(m, j) = arr(i, j)
    
31.                         Next
    
32.                         brr(m, 43) = Mid(fn, 9)
    
33.                     End If
    
34.                 Next
    
35.             End If
    
36.         End If
    
37.     Next f
    
38.     With sh
    
39.         .UsedRange.Offset(1).ClearContents
    
40.         .[a1].Resize(1, 43).Interior.Color = 49407
    
41.         With .[a2].Resize(m, 43)
    
42.             .Value = brr
    
43.             .Borders.LineStyle = 1
    
44.             .HorizontalAlignment = xlCenter
    
45.             .VerticalAlignment = xlCenter
    
46.             With .Font
    
47.                 .Name = "微软雅黑"
    
48.                 .Size = 11
    
49.             End With
    
50.         End With
    
51.     End With
    
52.     Application.ScreenUpdating = False
    
53.     MsgBox "共用时：" & Format(Timer - tm) & "秒！"
    
54. End Sub
    
55. 
    

复制代码

shiruiqiang

ykcbf1100草爷高产

ykcbf1100

shiruiqiang 发表于 2024-5-22 10:07
ykcbf1100草爷高产

这个写起来快

tanglf188

参与一下

baofa2

1. Option Explicit
   
2. 
   
3. Sub test1()
   
4.   
   
5.   Dim p As String
   
6.   With Application.FileDialog(msoFileDialogFolderPicker)
   
7.     .InitialFileName = ThisWorkbook.Path
   
8.     If .Show Then p = .SelectedItems(1) Else Exit Sub
   
9.   End With
   
10.   If Right(p, 1) <> "\" Then p = p & "\"
    
11.   
    
12.   Cells.ClearContents
    
13.   DoApp False
    
14.   
    
15.   Dim Conn As Object, rs As Object, dict As Object
    
16.   Dim strFields As String, SQL As String, f As String
    
17.   Dim i As Long, pos As Long
    
18.   
    
19.   Set dict = CreateObject("Scripting.Dictionary")
    
20.   Set Conn = CreateObject("ADODB.Connection")
    
21.   
    
22.   pos = 2
    
23.   f = Dir(p & "*.xls*")
    
24.   While Len(f)
    
25.     If ThisWorkbook.FullName <> p & f Then
    
26.       If Conn.State <> 1 Then
    
27.         Conn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source=" & p & f
    
28.         SQL = "SELECT * FROM [基本信息&商品信息$A22:AP22] WHERE FALSE"
    
29.         Set rs = Conn.Execute(SQL)
    
30.         For i = 0 To rs.Fields.Count - 1
    
31.           strFields = strFields & "`" & rs.Fields(i).Name & "`,"
    
32.           Range("A1").Offset(, i) = rs.Fields(i).Name
    
33.         Next
    
34.         Range("A1").Offset(, i) = "企业内部编号"
    
35.         rs.Close
    
36.         Set rs = Nothing
    
37.       End If
    
38.       SQL = "SELECT " & strFields & "'" & Split(Split(f, ".xls")(0), "数据")(1) & "' FROM [Excel 12.0;HDR=YES;Database=" & p & f & "].[基本信息&商品信息$A22:AP] WHERE LEN(商品编号)"
    
39.       dict.Add SQL, vbNullString
    
40.       If dict.Count = 49 Then
    
41.         SQL = Join(dict.Keys, " UNION ALL ")
    
42.         Range("A" & pos).CopyFromRecordset Conn.Execute(SQL)
    
43.         pos = Cells.Find("*", , xlValues, , xlByRows, xlPrevious).Row + 1
    
44.         dict.RemoveAll
    
45.       End If
    
46.     End If
    
47.     f = Dir
    
48.   Wend
    
49.   
    
50.   If dict.Count Then
    
51.     SQL = Join(dict.Keys, " UNION ALL ")
    
52.     Range("A" & pos).CopyFromRecordset Conn.Execute(SQL)
    
53.   End If
    
54.   Set dict = Nothing
    
55.   
    
56.   If Conn.State = 1 Then Conn.Close
    
57.   Conn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0 XML;Data Source=" & ThisWorkbook.FullName
    
58.   f = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\汇总表-" & Format(Date, "YYYYMMDD") & ".xlsx"
    
59.   If Dir(f) <> "" Then Kill f
    
60.   Conn.Execute "SELECT * INTO [" & f & "].[" & ActiveSheet.Name & "] FROM [" & ActiveSheet.Name & "$]"
    
61.   
    
62.   Conn.Close
    
63.   Set Conn = Nothing
    
64.   DoApp
    
65.   Beep
    
66. End Sub
    
67. 
    
68. Function DoApp(Optional b As Boolean = True)
    
69.   With Application
    
70.     .ScreenUpdating = b
    
71.     .DisplayAlerts = b
    
72.     .Calculation = -b * 30 - 4135
    
73.   End With
    
74. End Function
    

复制代码

baofa2

200左右工作簿-推荐SQL.zip (129.69 KB, 下载次数: 16)

2024-5-22 11:08 上传

点击文件名下载附件

limonet

关键字：into

limonet

Sub limonet()
    Dim Arr As Variant, PS As Object, i%, Cn As Object, StrSQL$
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show Then Path$ = .SelectedItems(1) Else Exit Sub
    End With
    Set PS = CreateObject("wscript.shell")
    Set Cn = CreateObject("Adodb.Connection")
    Cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0 xml;Data Source=" & PS.SpecialFolders("Desktop") & "\汇总表-" & Format(Date, "yyyymmdd")
    Arr = Split(PS.exec("powershell dir " & Path & " -name").stdout.readall, Chr(13) & Chr(10))
    For i = 0 To UBound(Arr) - 1
        j = j + 1: StrSQL = StrSQL & " Union All Select '" & Mid(Left(Arr(i), Len(Arr(i)) - 5), InStrRev(Arr(i), "导出数据") + 4) & "' as 企业内部编号,* From [Excel 12.0;Database=" & Path & "\" & Arr(i) & "].[基本信息&商品信息$A22:AP] where 项号<>''"
        If j = 48 Or i = UBound(Arr) - 1 Then
            If Cn.OpenSchema(20, Array(Empty, Empty, "汇总表", Empty)).EOF Then
                StrSQL = "Select * Into 汇总表 From (" & Mid(StrSQL, 12) & ")"
            Else
                StrSQL = "Insert Into 汇总表 Select * From (" & Mid(StrSQL, 12) & ")"
            End If
            Cn.Execute (StrSQL): j = 0: StrSQL = ""
        End If
    Next i
End Sub