能否一键读取《数据》文件夹下所有工作簿非空工作表的B8:D19数据?

gzclc

能否一键读取《数据》文件夹下所有工作簿非空工作表的B8:D19数据，并生成3个备注（备注1为工作簿名称，备注2为工作表名称，备注3为工作表A6数据）？

fzxba

汇总.rar (43.2 KB, 下载次数: 21)

2024-3-1 18:55 上传

点击文件名下载附件

^星^

汇总.zip (45.18 KB, 下载次数: 11)

2024-3-1 19:20 上传

点击文件名下载附件

gwjkkkkk

Option Explicit
Sub test1()
    Dim ar, br, i&, j&, r&, f, p$, wks As Worksheet
   
    Application.ScreenUpdating = False
   
    ReDim ar(1 To 10 ^ 3, 1 To 7)
    p = ThisWorkbook.Path & "\数据\"
    For Each f In CreateObject("Scripting.FileSystemObject").GetFolder(p).Files
        If f.Name <> ThisWorkbook.Name Then
            If f.Name Like "*.xls" Then
                With GetObject(f)
                    For Each wks In .Worksheets
                        If IsEmpty(wks.UsedRange) = False Then
                            br = wks.[A6].CurrentRegion.Value
                            For i = 3 To UBound(br)
                                r = r + 1
                                For j = 1 To UBound(br, 2)
                                    ar(r, j) = br(i, j)
                                Next j
                                ar(r, 1) = r
                                ar(r, 5) = f.Name
                                ar(r, 6) = wks.Name
                                ar(r, 7) = br(1, 1)
                            Next i
                        End If
                    Next wks
                    .Close False
                End With
            End If
        End If
    Next
   
    If r Then
        [I5].Resize(r, UBound(ar, 2)) = ar
    End If

    Application.ScreenUpdating = True
    Beep
End Sub

gwjkkkkk

请参考。。。

飞天篮球猪

仅供参考...

3000个工作簿可以跑进5秒

ykcbf1100

附件供参考。。。

ykcbf1100

代码供参考。。。

1. Sub ykcbf()   '//2024.3.1
   
2.     Set Fso = CreateObject("scripting.filesystemobject")
   
3.     Application.ScreenUpdating = False
   
4.     Set sh = ThisWorkbook.Sheets("汇总")
   
5.     ReDim brr(1 To 10000, 1 To 7)
   
6.     p = ThisWorkbook.Path & "\数据"
   
7.     For Each f In Fso.GetFolder(p).Files
   
8.         If f.Name Like "*.xls*" Then
   
9.             fn = Fso.GetBaseName(f)
   
10.             Set wb = Workbooks.Open(f, 0)
    
11.             For Each sht In wb.Sheets
    
12.                 If IsArray(sht.UsedRange) Then
    
13.                     With sht
    
14.                         r = .Cells(Rows.Count, 1).End(3).Row
    
15.                         arr = .Range("a7:d" & r)
    
16.                         fn1 = .Name
    
17.                         xm = .[a6]
    
18.                     End With
    
19.                     For i = 2 To UBound(arr)
    
20.                         m = m + 1
    
21.                         brr(m, 1) = m
    
22.                         For j = 2 To UBound(arr, 2)
    
23.                             brr(m, j) = arr(i, j)
    
24.                         Next
    
25.                         brr(m, 5) = fn
    
26.                         brr(m, 6) = fn1
    
27.                         brr(m, 7) = xm
    
28.                     Next
    
29.                 End If
    
30.             Next
    
31.             wb.Close False
    
32.         End If
    
33.     Next f
    
34.     With sh
    
35.         .[a5:g10000].Clear
    
36.         With .[a5].Resize(m, 7)
    
37.             .Value = brr
    
38.             .Borders.LineStyle = 1
    
39.             .HorizontalAlignment = xlCenter
    
40.             .VerticalAlignment = xlCenter
    
41.         End With
    
42.     End With
    
43.     MsgBox "OK！"
    
44.     Application.ScreenUpdating = True
    
45. End Sub
    

复制代码

gzclc

ykcbf1100 发表于 2024-3-1 20:12
代码供参考。。。

ykcbf1100,我只要汇总B8:D19区域的数据，其他不用，如何修改？

ykcbf1100

gzclc 发表于 2024-3-2 20:48
ykcbf1100,我只要汇总B8:D19区域的数据，其他不用，如何修改？

取数范围改一下就行了。