数据汇总的问题

杨小妹

附件 汇总附件.rar (82.4 KB, 下载次数: 16)

2024-6-18 11:36 上传

点击文件名下载附件

谢谢老师！

baofa2

1. Option Explicit
   
2. 
   
3. Sub test0()
   
4.   
   
5.   Dim Conn As Object, dict As Object, target As Range
   
6.   Dim strConn As String, p As String, f As String, s As String
   
7.   
   
8.   Set target = Range("A1")
   
9.   target.CurrentRegion.ClearContents
   
10.   Application.ScreenUpdating = False
    
11.   
    
12.   Set dict = CreateObject("Scripting.Dictionary")
    
13.   Set Conn = CreateObject("ADODB.Connection")
    
14.   s = "Excel 12.0;HDR=NO;Database="
    
15.   If Application.Version < 12 Then
    
16.     s = Replace(s, "12.0", "8.0")
    
17.     strConn = "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties=Excel 8.0;Data Source="
    
18.   Else
    
19.     strConn = "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source="
    
20.   End If
    
21.   Conn.Open strConn & ThisWorkbook.FullName
    
22.   
    
23.   p = ThisWorkbook.Path & "\"
    
24.   f = Dir(p & "*.xlsb")
    
25.   
    
26.   While Len(f)
    
27.     If p & f <> ThisWorkbook.FullName Then
    
28.       dict.Add "SELECT * FROM [" & s & p & f & "].[$A1:E] WHERE LEN(F1)", ""
    
29.       If dict.Count = 49 Then
    
30.         target.CopyFromRecordset Conn.Execute(Join(dict.Keys, " UNION ALL "))
    
31.         Set target = Cells(Rows.Count, "A").End(xlUp).Offset(1)
    
32.         dict.RemoveAll
    
33.       End If
    
34.     End If
    
35.     f = Dir
    
36.   Wend
    
37.   
    
38.   If dict.Count Then target.CopyFromRecordset Conn.Execute(Join(dict.Keys, " UNION ALL "))
    
39.   
    
40.   Conn.Close
    
41.   Set Conn = Nothing
    
42.   Set target = Nothing
    
43.   Set dict = Nothing
    
44.   
    
45.   Application.ScreenUpdating = True
    
46.   Beep
    
47. End Sub
    

复制代码

ykcbf1100

参与一下。。。

香川合并法。

ykcbf1100

香川合并法

1. Sub ykcbf()   '//2024.6.18    香川合并法
   
2.     Application.ScreenUpdating = False
   
3.     Application.DisplayAlerts = False
   
4.     Dim tm: tm = Timer
   
5.     Dim brr, arr, x
   
6.     p = ThisWorkbook.Path
   
7.     Set sh = ThisWorkbook.Sheets("Sheet1")
   
8.     brr = Split(CreateObject("Wscript.Shell").exec("cmd /c dir /a-d /b /s " & Chr(34) & p & Chr(34)).StdOut.ReadAll, vbCrLf)
   
9.     brr = Filter(brr, ThisWorkbook.Name, 0)
   
10.     sh.UsedRange.ClearContents
    
11.     For x = 0 To UBound(brr)
    
12.         m = m + 1
    
13.         If Len(brr(x)) Then
    
14.             Set wb = Workbooks.Open(brr(x), 0)
    
15.             With wb.Sheets("Sheet1")
    
16.                 r = .Cells(Rows.Count, 1).End(3).Row
    
17.                 arr = [a1].Resize(r, 5)
    
18.             End With
    
19.             wb.Close 0
    
20.             r = IIf(m = 1, 1, sh.Cells(sh.Rows.Count, "a").End(xlUp).Offset(1).Row)
    
21.             sh.Cells(r, 1).Resize(UBound(arr), UBound(arr, 2)) = arr
    
22.         End If
    
23.     Next
    
24.     Application.ScreenUpdating = True
    
25.     MsgBox "运行完毕，共用时： " & Format(Timer - tm, "0.000秒"), , "提示"
    
26. End Sub
    
27. 
    

复制代码

dragonthree

brr = Split(CreateObject("Wscript.Shell").exec("cmd /c dir /a-d /b /s " & Chr(34) & p & Chr(34)).StdOut.ReadAll, vbCrLf)
学习了！

LIUZHU

ykcbf1100 发表于 2024-6-18 12:37
香川合并法

哇，这是什么啊？reateObject("Wscript.Shell").exec("cmd /c dir /a-d /b /s " & Chr(34) & p & Chr(34)).StdOut.ReadAll

LIUZHU

汇总效果如动图

LIUZHU

JS代码，供参考

1. function 汇总(){
   
2.         let fname=Dir(`${ThisWorkbook.Path}\\*.xlsb`,8);
   
3.         let res=[];
   
4.         while(fname!=""){
   
5.                 Workbooks.Open(`${ThisWorkbook.Path}\\${fname}`);
   
6.                 res.push(...Range("a1").CurrentRegion.Value2);
   
7.                 ActiveWorkbook.Close(false);
   
8.                 fname=Dir();
   
9.         }
   
10.         Range("a1").Resize(res.length,res[0].length).Value2=res;
    
11. }

复制代码

LIUZHU

附件，WPS测试，谢谢！