遍历多个文件夹提取工作簿名称，高手留步。

jsgj2023

遍历多个文件夹，提取每个文件夹中所有工作簿的名称。

duquancai

请借鉴修改》》》》》》

1. Sub shishi()
   
2.     pa = ThisWorkbook.Path & ""
   
3.     arr = wwj(pa)
   
4.     Range("a1").Resize(UBound(arr), 1) = Application.Transpose(arr)
   
5. End Sub
   
6. Function wwj(pa, Optional n = 1)
   
7.     Dim arr(), brr(), f, q As Integer, f1
   
8.     ReDim arr(1 To 1): arr(1) = pa
   
9.     i = 1: k = 1
   
10.     Do While i <= k
    
11.         If arr(i) = "" Then Exit Do
    
12.         f = Dir(arr(i), vbDirectory)
    
13.         Do While f <> ""
    
14.             If InStr(f, ".") = 0 And f <> "" Then
    
15.                 k = k + 1: ReDim Preserve arr(1 To k)
    
16.                 arr(k) = arr(i) & f & ""
    
17.             End If
    
18.             f = Dir
    
19.         Loop
    
20.         i = i + 1
    
21.     Loop
    
22.     For x = 1 To UBound(arr)
    
23.         If arr(x) = "" Then Exit For
    
24.         f1 = Dir(arr(x) & "*.xls*")
    
25.         Do While f1 <> ""
    
26.             If arr(x) & f1 = ThisWorkbook.FullName Then GoTo 100
    
27.             q = q + 1: ReDim Preserve brr(1 To q)
    
28.             brr(q) = arr(x) & f1
    
29. 100             f1 = Dir
    
30.         Loop
    
31.     Next
    
32.     wwj = brr
    
33. End Function

复制代码

duquancai

详见附件》》》》》》》》点击按钮

fxl447098457

1. Sub getdata()
   
2. Dim Wsh As Object, DirStr$, FileStr$, arr, brr, crr(), i%, j%, m, n, k%
   
3. On Error Resume Next
   
4. Set Wsh = CreateObject("wscript.shell")
   
5. DirStr = Wsh.Exec("cmd.exe /c dir /A:D /s/b " & ThisWorkbook.Path & "\文件集合").StdOut.ReadAll
   
6. arr = Split(Left(DirStr, Len(DirStr) - 1), vbCrLf)
   
7. For i = 0 To UBound(arr)
   
8.     FileStr = Wsh.Exec("cmd.exe /c dir /s/b " & arr(i) & "\*.*").StdOut.ReadAll
   
9.     If Len(FileStr) Then brr = Split(Left(FileStr, Len(FileStr) - 1), vbCrLf) Else brr = Array("")
   
10.       m = Split(arr(i), "")
    
11.     For j = 0 To UBound(brr)
    
12.         k = k + 1: ReDim Preserve crr(1 To 2, 1 To k)
    
13.         crr(1, k) = m(UBound(m))
    
14.         n = Split(Split(brr(j), ".xl")(0), "")
    
15.         crr(2, k) = n(UBound(n))
    
16.         If Err <> 0 Then crr(2, k) = "": Err.Clear
    
17.     Next j
    
18. Next i
    
19. ActiveSheet.UsedRange.ClearContents
    
20. [a1].Resize(k, 2) = WorksheetFunction.Transpose(crr)
    
21. End Sub

复制代码

非常6-1

记号！！！！！！！！！！！=100000000