合并同一文件夹下多个工作簿汇总到一个工作表中并汇总，合并物品的名称，累加数量

losve

合并同一文件夹下多个工作簿汇总到一个工作表中并汇总，合并物品的名称，累加数量


由于实际操作中表格数量和内容都很多，工作效率太低了

请各位高手帮忙看下，谢谢大家！
请参考附件

采购汇总.zip (38.11 KB, 下载次数: 21)

2024-7-30 00:46 上传

点击文件名下载附件

quqiyuan

参与一下，供参考。。。

limonet

关键字：union all

limonet

Sub limonet()
    Dim Cn As Object, StrSQL$
    Set Cn = CreateObject("Adodb.Connection")
    Cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source=" & ThisWorkbook.FullName
    Path = ThisWorkbook.Path & "\申请单\"
    Filename = Dir(Path & "*.xls")
    Do While Filename <> ""
        StrSQL = StrSQL & " Union All Select F1 as Name,F2 as Kind,F3 as Unit,F10 as Qty From [Excel 12.0;Hdr=No;DataBase=" & Path & Filename & "].[物资需求计划报审表-设备配件$C6:L] Where F1<>''"
        Filename = Dir
    Loop
    StrSQL = "Select name,kind,First(unit),Sum(qty) From (" & Mid(StrSQL, 12) & ") Group By name,kind"
    Range("B6").CopyFromRecordset Cn.Execute(StrSQL)
End Sub

ykcbf1100

附件供参考。。。

ykcbf1100

多工作簿合并

1. Sub ykcbf()         '//2024.7.30
   
2.     Application.ScreenUpdating = False
   
3.     Application.DisplayAlerts = False
   
4.     Dim arr, brr(1 To 10000, 1 To 30)
   
5.     Set fso = CreateObject("Scripting.FileSystemObject")
   
6.     Set d = CreateObject("Scripting.Dictionary")
   
7.     Set sh = ThisWorkbook.Sheets("物资汇总表")
   
8.     p = ThisWorkbook.Path & "\申请单"
   
9.     b = [{1,3,4,5,12}]
   
10.     For Each f In fso.GetFolder(p).Files
    
11.         If LCase$(f.Name) Like "*.xls*" Then
    
12.             fn = fso.GetBaseName(f)
    
13.             Set wb = Workbooks.Open(f, 0)
    
14.             With wb.Sheets("物资需求计划报审表-设备配件")
    
15.                 arr = .UsedRange
    
16.             End With
    
17.             wb.Close 0
    
18.             For i = 6 To UBound(arr)
    
19.                 If Val(arr(i, 1)) Then
    
20.                     s = arr(i, 3) & "|" & arr(i, 4) & "|" & arr(i, 5)
    
21.                     If Not d.exists(s) Then
    
22.                         m = m + 1
    
23.                         d(s) = m
    
24.                         brr(m, 1) = m
    
25.                         For x = 2 To UBound(b)
    
26.                             brr(m, x) = arr(i, b(x))
    
27.                         Next
    
28.                     Else
    
29.                         r = d(s)
    
30.                         brr(r, 5) = brr(r, 5) + arr(i, 12)
    
31.                     End If
    
32.                 End If
    
33.             Next
    
34.         End If
    
35.     Next f
    
36.     With sh
    
37.         .UsedRange.Offset(5).ClearContents
    
38.         With .[a6].Resize(m, 5)
    
39.             .Value = brr
    
40.             .Borders.LineStyle = 1
    
41.             .HorizontalAlignment = xlCenter
    
42.             .VerticalAlignment = xlCenter
    
43.         End With
    
44.     End With
    
45.     Set d = Nothing
    
46.     Application.ScreenUpdating = True
    
47.     MsgBox "OK！"
    
48. End Sub
    

复制代码

losve

quqiyuan 发表于 2024-7-30 08:39
参与一下，供参考。。。

谢谢，我试试

losve

ykcbf1100 发表于 2024-7-30 10:49
多工作簿合并

谢谢大家，我都试试