跨文件数据汇总到总表

天真无鞋

求助那位老师帮忙用VBA写个代码，跨文件夹将多个数据汇总到总表，详见附件说明。

LIUZHU

是这个效果吗？

LIUZHU

JS代码，请参考

1. function 导入数据(){
   
2.         let folder=Dir(`${ThisWorkbook.Path}\\`,16);
   
3.         let res=[];
   
4.         while(folder!=""){
   
5.                 if (folder!="." && folder!=".." && folder!=ThisWorkbook.Name){
   
6.                         let fname=Dir(`${ThisWorkbook.Path}\\${folder}\\*.xls*`);
   
7.                         Workbooks.Open(`${ThisWorkbook.Path}\\${folder}\\${fname}`);
   
8.                         let arr=Range("b2:bp" + Range("b2").End(xlDown).Row).Value2;
   
9.                         res.push(...arr);
   
10.                         ActiveWorkbook.Close(false);
    
11.                 }
    
12.                 folder=Dir();
    
13.         }
    
14.         Range(`4:${Math.max(4,Rows.Count)}`).ClearContents();
    
15.         Range("a4").Resize(res.length,res[0].length).Value2=res;
    
16. }

复制代码

LIUZHU

附件需要用WPS测试

yanglinzi

1. Sub 汇总()
   
2. Dim arr, brr, i, j, r
   
3. Application.ScreenUpdating = False
   
4. Application.DisplayAlerts = False
   
5. Set fso = CreateObject("scripting.filesystemobject")
   
6. p = ThisWorkbook.Path & ""
   
7. c = Sheet4.Cells(3, Columns.Count).End(xlToLeft).Column
   
8. ReDim brr(1 To 100000, 1 To c)
   
9. For Each fd In fso.getfolder(p).subfolders
   
10.     For Each f In fd.Files
    
11.         Debug.Print fd.Name
    
12.         Debug.Print f.Name
    
13.         Set wb = Workbooks.Open(f)
    
14.         Set sh = wb.Sheets(1)
    
15.         arr = sh.UsedRange
    
16.         wb.Close False
    
17.         For i = 2 To UBound(arr)
    
18.             If arr(i, 2) <> "" Then
    
19.                 n = n + 1
    
20.                 For j = 2 To UBound(arr, 2)
    
21.                     brr(n, j - 1) = arr(i, j)
    
22.                 Next
    
23.             End If
    
24.         Next
    
25.     Next
    
26. Next
    
27. With Sheet4
    
28.     .UsedRange.Offset(1).ClearContents
    
29.     r = .Cells(Rows.Count, 1).End(xlUp).Row
    
30.     .Cells(r + 1, 1).Resize(n, c) = brr
    
31. End With
    
32. Application.ScreenUpdating = True
    
33. Application.DisplayAlerts = True
    
34. End Sub
    

复制代码

yanglinzi

参与一下。。

cnmlgb9998

用 PQ 解决方案

天真无鞋

yanglinzi 发表于 2024-5-12 11:35
参与一下。。

辛苦老师了非常正确，如果我要改导入存放数据的位置需改哪里，谢谢老师

天真无鞋

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

没有使用WPS，非常感觉你

Qs18

Sub text()
    Dim wb As Workbook, ws As Worksheet
    Dim folderPath As String, fileName As String
    Dim queue As Object, folder As Variant
    Set queue = CreateObject("System.Collections.Queue")
    Application.ScreenUpdating = False
    ' 设置当前工作簿和工作表
    Set wb = ThisWorkbook
    Set ws = wb.Sheets(1)
   
    ' 获取当前工作簿所在的文件夹路径并加入队列
    folderPath = wb.Path
    Call queue.Enqueue(folderPath)
   
    Do While queue.Count > 0
        ' 从队列中取出一个文件夹路径
        folder = queue.Dequeue()
        
        ' 遍历文件夹中的所有文件和子文件夹
        fileName = Dir(folder & "\*", vbNormal Or vbReadOnly Or vbHidden Or vbSystem Or vbDirectory)
        Do While fileName <> ""
            If (GetAttr(folder & "\" & fileName) And vbDirectory) = vbDirectory Then
                ' 如果是文件夹，则加入队列
                If fileName <> "." And fileName <> ".." Then
                    Call queue.Enqueue(folder & "\" & fileName)
                End If
            Else
                ' 如果是文件，汇总数据
                If LCase(Right(fileName, 4)) = ".xls" Or LCase(Right(fileName, 5)) = ".xlsx" Then
                    ' 打开文件并复制数据
                    Workbooks.Open folder & "\" & fileName
                    With ActiveWorkbook
                        With .Worksheets(1)
                            If Not .UsedRange Is Nothing Then
                                ' 找到汇总工作簿的最后一行
                                Dim lastRow As Long
                                lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row + 1
                                Dim h '活动工作表的最大行号
                                h = Cells(Rows.Count, 1).End(xlUp).Row

                                ' 复制数据到汇总工作簿
                                .Range("b2:BP" & h).Copy Destination:=ws.Cells(lastRow, 1)
                            End If
                        End With
                        .Close SaveChanges:=False
                    End With
                End If
            End If
            fileName = Dir() ' 获取下一个文件名
        Loop
    Loop
Application.ScreenUpdating = True
    MsgBox "数据汇总完成！"
End Sub