求助采集提取文件夹里面任意EXcel格式（xls或xlsx）的内容信息

ruhong18

求助采集提取文件夹里面任意EXcel格式（xls或xlsx）的内容信息

liulang0808

建议楼主结合附件内容详细描述下需求，以下链接是遍历文件相关的
https://club.excelhome.net/threa ... tml?_dsign=73cffde5

ykcbf1100

任何文件夹，这个说法并不明确啊，是指当前目录下多个子目录呢，还是当前目录下有多级子目录呢？

ykcbf1100

代码适用范围：只存在一级子目录

ykcbf1100

。。。。。。。。。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()   '//2024.6.13
   
2.     Application.ScreenUpdating = False
   
3.     Set fso = CreateObject("scripting.filesystemobject")
   
4.     Set sh = ThisWorkbook.Sheets("Sheet1")
   
5.     p = ThisWorkbook.Path & ""
   
6.     Set ff = fso.GetFolder(p)
   
7.     b = [{"f2","a3","e3","a4","a4","a5","a6","a7","a8","g8","a9","g9","a10","g10","a11","g11","a12","g12","a13","g13","a32"}]
   
8.     ReDim brr(1 To 10000, 1 To UBound(b))
   
9.     For Each fd In ff.SubFolders
   
10.         For Each f In fd.Files
    
11.             If LCase$(f.Name) Like "*.xls*" Then
    
12.                 fn = fso.GetBaseName(f)
    
13.                 Set wb = Workbooks.Open(f, 0)
    
14.                 m = m + 1
    
15.                 With wb.Sheets(1)
    
16.                     For j = 1 To UBound(b)
    
17.                         brr(m, j) = .Range(b(j))
    
18.                     Next
    
19.                 End With
    
20.                 wb.Close False
    
21.             End If
    
22.         Next f
    
23.     Next fd
    
24.     With sh
    
25.         .[a2:o10000] = ""
    
26.         .[a2].Resize(m, 15) = brr
    
27.     End With
    
28.     Application.ScreenUpdating = True
    
29.     MsgBox "OK！"
    
30. End Sub
    

复制代码

ruhong18

ykcbf1100 发表于 2024-6-13 08:59
任何文件夹，这个说法并不明确啊，是指当前目录下多个子目录呢，还是当前目录下有多级子目录呢？

您好，老师！对的，当前目录就可以