[已解决]新手求助 工作簿提取名字

123小木头人

我根据校长的遍历文件夹 可是不能把某些文件夹的工作簿名称提取出来  麻烦更我解决哈

最佳答案

月排行榜 / 总排行榜

wp8680

2013-8-30 19:27

1. Sub 提取文件信息()
   
2.   Dim arr(1 To 10000) As String
   
3.   Dim f, i, k, f2, f3, x
   
4.   Dim brr(1 To 100000, 1 To 6) As String, q As Integer
   
5.   Dim fso As Object, myfile As Object
   
6.   arr(1) = ThisWorkbook.Path & ""
   
7.   i = 1: k = 1
   
8.   Do While i < UBound(arr)
   
9.     If arr(i) = "" Then Exit Do
   
10.     f = Dir(arr(i), vbDirectory)
    
11.     Do
    
12.       If Not (f Like "*.xl*") And f <> "" And InStr(f, ".") <> 1 Then '原来你的错误就在由于文件夹是由*.*表示的，这跟工作表的后缀名中的.冲突了。
    
13.         k = k + 1
    
14.         arr(k) = arr(i) & f & ""
    
15.       End If
    
16.       f = Dir
    
17.     Loop Until f = ""
    
18.     i = i + 1
    
19.   Loop
    
20.   '*******下面是提取各个文件夹的文件***
    
21.   Set fso = CreateObject("Scripting.FileSystemObject")
    
22.   For x = 1 To UBound(arr)
    
23.       If arr(x) = "" Then Exit For
    
24.        f3 = Dir(arr(x) & "*.xls*")
    
25.      Do While f3 <> ""
    
26.        q = q + 1
    
27.        brr(q, 6) = arr(x) & f3
    
28.        Set myfile = fso.GetFile(brr(q, 6))
    
29.        brr(q, 1) = f3
    
30.        brr(q, 2) = myfile.Size
    
31.        brr(q, 3) = myfile.DateCreated
    
32.        brr(q, 4) = myfile.DateLastModified
    
33.        brr(q, 5) = myfile.DateLastAccessed
    
34.        f3 = Dir
    
35.      Loop
    
36.   Next x
    
37.   Range("a2").Resize(1000, 6) = ""
    
38.   Range("a2").Resize(q, 6) = brr
    
39. End Sub

复制代码

跳转到最佳答案楼层

hwc2ycy

1. Dim objList As Collection
   
2. 
   
3. Sub main()
   
4.     Dim strPath As String
   
5.     Dim arr
   
6.     Dim i As Long
   
7.     Set objList = New Collection
   
8.     With Application.FileDialog(msoFileDialogFolderPicker)
   
9.         .AllowMultiSelect = False
   
10.         .InitialFileName = ThisWorkbook.Path
    
11.         If .Show = -1 Then
    
12.             strPath = .SelectedItems(1)
    
13.         Else
    
14.             MsgBox "请先选择要遍布的文件夹"
    
15.             Exit Sub
    
16.         End If
    
17.     End With
    
18.     Call fso(strPath & Application.PathSeparator)
    
19.     If objList.Count Then
    
20.         ReDim arr(1 To objList.Count, 1 To 1)
    
21.         For i = 1 To objList.Count
    
22.             arr(i, 1) = objList(i)
    
23.         Next
    
24.         Range("a1").Resize(i - 1).Value = arr
    
25.         MsgBox "一共查到 " & i - 1 & " 个工作簿"
    
26.     End If
    
27.     Set objList = Nothing
    
28. End Sub
    
29. 
    
30. Sub fso(ByVal sPath As String)
    
31.     Dim fs As Object
    
32.     Dim fd As Object
    
33.     Dim fc As Object
    
34.     Dim s, d
    
35.     Set fs = CreateObject("scripting.filesystemobject")
    
36.     Set fd = fs.getfolder(sPath)
    
37.     Set fc = fd.Files
    
38.     For Each s In fc
    
39.         If UCase(s.Path) Like "*.XL*" Then
    
40.             objList.Add s.Path
    
41.         End If
    
42.     Next
    
43.     For Each d In fd.SubFolders
    
44.         fso d.Path
    
45.     Next
    
46. End Sub

复制代码

wp8680

1. Sub 提取文件信息()
   
2.   Dim arr(1 To 10000) As String
   
3.   Dim f, i, k, f2, f3, x
   
4.   Dim brr(1 To 100000, 1 To 6) As String, q As Integer
   
5.   Dim fso As Object, myfile As Object
   
6.   arr(1) = ThisWorkbook.Path & ""
   
7.   i = 1: k = 1
   
8.   Do While i < UBound(arr)
   
9.     If arr(i) = "" Then Exit Do
   
10.     f = Dir(arr(i), vbDirectory)
    
11.     Do
    
12.       If Not (f Like "*.xl*") And f <> "" And InStr(f, ".") <> 1 Then '原来你的错误就在由于文件夹是由*.*表示的，这跟工作表的后缀名中的.冲突了。
    
13.         k = k + 1
    
14.         arr(k) = arr(i) & f & ""
    
15.       End If
    
16.       f = Dir
    
17.     Loop Until f = ""
    
18.     i = i + 1
    
19.   Loop
    
20.   '*******下面是提取各个文件夹的文件***
    
21.   Set fso = CreateObject("Scripting.FileSystemObject")
    
22.   For x = 1 To UBound(arr)
    
23.       If arr(x) = "" Then Exit For
    
24.        f3 = Dir(arr(x) & "*.xls*")
    
25.      Do While f3 <> ""
    
26.        q = q + 1
    
27.        brr(q, 6) = arr(x) & f3
    
28.        Set myfile = fso.GetFile(brr(q, 6))
    
29.        brr(q, 1) = f3
    
30.        brr(q, 2) = myfile.Size
    
31.        brr(q, 3) = myfile.DateCreated
    
32.        brr(q, 4) = myfile.DateLastModified
    
33.        brr(q, 5) = myfile.DateLastAccessed
    
34.        f3 = Dir
    
35.      Loop
    
36.   Next x
    
37.   Range("a2").Resize(1000, 6) = ""
    
38.   Range("a2").Resize(q, 6) = brr
    
39. End Sub

复制代码