跨文件数据汇总到总表

zpy2

天真无鞋 发表于 2024-5-12 12:07
辛苦老师了非常正确，如果我要改导入存放数据的位置需改哪里，谢谢老师

Sheet4改一下

天真无鞋

zpy2 发表于 2024-5-12 12:24
Sheet4改一下

明白了，谢谢老师

天真无鞋

Qs18 发表于 2024-5-12 12:12
Sub text()
    Dim wb As Workbook, ws As Worksheet
    Dim folderPath As String, fileName As Strin ...

谢谢老师

limonet

关键字：recurse+union all

limonet

Sub Limonet()
    Dim Arr As Variant, Fs$, i%, 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
    Fs = "F2,F3,F4,F5,F6,F7,F8,F9,F10,F11,F12,Null,F14,F15,F16,F17,F18,F19,F20,F21,F22,F23,F24,F25,F26,F27,F28,F29,F30,F31,F32,F33,F34,F35,F36,F37,F38,F39,F40,F41,F42,F43,F44,F45,F46,F47,F48,F49,F50,F51,F52,F53,F54,F55,F56,F57,F58,F59,F60,F61,F62,F63,F64,F65,F66,F67,F68"
    Arr = Split(CreateObject("WScript.Shell").Exec("Powershell get-childitem " & ThisWorkbook.Path & " -recurse -file *.xlsx | select fullname").StdOut.ReadAll, Chr(13) & Chr(10))
    For i = 3 To UBound(Arr) - 3
        StrSQL = StrSQL & " Union All Select " & Fs & " From [Excel 12.0;Hdr=No;DataBase=" & Arr(i) & "].[Audit Log QA list$A2:BP] Where F1>0"
    Next i
    Range("A4").CopyFromRecordset Cn.Execute(Mid(StrSQL, 12))
End Sub

天真无鞋

limonet 发表于 2024-5-12 19:02
关键字：recurse+union all

谢谢老师

yanglinzi

天真无鞋 发表于 2024-5-12 12:07
辛苦老师了非常正确，如果我要改导入存放数据的位置需改哪里，谢谢老师

就改sheet4的值

ykcbf1100

参与一下。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()   '//2024.5.13
   
2.     Application.ScreenUpdating = False
   
3.     Dim fns As New Collection
   
4.     p = ThisWorkbook.Path & ""
   
5.     Set sh = ThisWorkbook.Sheets("Sheet4")
   
6.     Set fso = CreateObject("Scripting.FileSystemObject")
   
7.     Set ff = fso.GetFolder(p)
   
8.     getFiles ff, fns, fso
   
9.     ReDim brr(1 To 10000, 1 To 300)
   
10.     For Each f In fns
    
11.         Set wb = Workbooks.Open(f, 0)
    
12.         With wb.Sheets(1)
    
13.             r = .Cells(Rows.Count, 1).End(3).Row
    
14.             c = .UsedRange.Columns.Count
    
15.             arr = .[a1].Resize(r, c)
    
16.         End With
    
17.         wb.Close False
    
18.         For i = 2 To UBound(arr)
    
19.             m = m + 1
    
20.             For j = 2 To UBound(arr, 2)
    
21.                 brr(m, j - 1) = arr(i, j)
    
22.             Next
    
23.         Next
    
24.     Next
    
25.     With sh
    
26.         .Rows(4 & ":" & 1000) = ""
    
27.         .[a4].Resize(m, c - 1) = brr
    
28.         .[a4].Resize(m, c - 1).Borders.LineStyle = 1
    
29.     End With
    
30.     Application.ScreenUpdating = True
    
31.     MsgBox "OK！"
    
32. End Sub

复制代码

sulli112

LIUZHU 发表于 2024-5-12 11:34
附件需要用WPS测试

不好意思想请教一下，您这段代码市合并文件夹下工作簿数据吗？为啥我测试了一下，好像只合并第一份文件夹的数据？