汇总多个文件内相同名工作簿中Sheet2工作表内的数据

mrkevinss

ykcbf1100 发表于 2023-3-6 09:26
遍历文件夹指定工作簿数据合并数组法。

老师，能设置按照文件夹的顺序来提取吗？

mrkevinss

gwjkkkkk 发表于 2023-3-4 19:10
请参考。。。

或者在F列添加所属文件夹名称

mrkevinss

ykcbf1100 发表于 2023-3-6 09:26
遍历文件夹指定工作簿数据合并数组法。

老师，可以在F列添加所属文件夹名称吗？

gwjkkkkk

mrkevinss 发表于 2023-3-11 11:39
老师，能设置按照文件夹的顺序来提取吗？

文件夹读取按文件夹名自动读取，你可以更改文件名称，来让程序按顺序读取。。。

mrkevinss

gwjkkkkk 发表于 2023-3-11 14:18
文件夹读取按文件夹名自动读取，你可以更改文件名称，来让程序按顺序读取。。。

那可以在F列显示所在文件夹名称吗？

gwjkkkkk

mrkevinss 发表于 2023-3-11 14:23
那可以在F列显示所在文件夹名称吗？

如果回复满意，右下角评分。。。

cai2532

这个贴不错，学习了

he_zai

ykcbf1100 发表于 2023-3-6 09:26
遍历文件夹指定工作簿数据合并数组法。

如何改为工作簿所有工作表。

1. 
   
2. Sub 数组法合并()   '//2023.3.6
   
3.     Dim p$, s%, x%, ff$, f$, arr(1 To 100), wb As Workbook
   
4.     Dim r%, m%, brr, crr
   
5.     Set zwb = ThisWorkbook
   
6.     Set sh = zwb.Sheets(1)
   
7.     sh.UsedRange.Offset(1, 0).ClearContents
   
8.     p = ThisWorkbook.Path & ""
   
9.     ff = Dir(p & "*", 16)                '//子文件夹
   
10.     Application.DisplayAlerts = False
    
11.     Application.ScreenUpdating = False
    
12.     Application.EnableEvents = False
    
13.     Dim tm: tm = Timer
    
14.     For Each wb In Workbooks
    
15.         If wb.Name <> ThisWorkbook.Name Then wb.Close
    
16.     Next
    
17.     Do While ff <> ""
    
18.         If Not ff Like ".*" Then
    
19.             If GetAttr(p & ff) = 16 Then
    
20.                 s = s + 1
    
21.                 arr(s) = ff
    
22.             End If
    
23.         End If
    
24.         ff = Dir
    
25.     Loop
    
26.     On Error Resume Next
    
27.     For i = 1 To s                                      '//子目录循环
    
28.         f = Dir(p & arr(i) & "\*汇总信息*.xls*")
    
29.         Do While f <> "" And InStr(f, ThisWorkbook.Name) = 0
    
30.             With GetObject(p & arr(i) & "" & f)
    
31.                'With .Sheets(2)'只是工作表2，如何改为工作簿的所有工作表
    
32.                
    
33.                     r = .Cells(.Rows.Count, "a").End(xlUp).Row
    
34.                     brr = .Range("a2:e" & r)
    
35.                     r2 = sh.Cells(sh.Rows.Count, "a").End(xlUp).Row + 1
    
36.                     sh.Cells(r2, 1).Resize(r - 1, 5).Value = brr
    
37.                 End With
    
38.                 .Close False
    
39.             End With
    
40.             f = Dir
    
41.         Loop
    
42.     Next
    
43.     Application.EnableEvents = True
    
44.     Application.ScreenUpdating = True
    
45.     Application.DisplayAlerts = True
    
46.     MsgBox "运行完毕，共用时： " & Format(Timer - tm, "0.000秒"), , "提示"
    
47. End Sub
    

复制代码