VBA 如何取得指定路徑的所有檔案名稱

zero5708

我想要寫一個VBA程式
活頁簿 1  是個 VBA搜尋
能輸入  路徑  之後把  
路徑裡面的檔案名稱(包含 路徑裡面子資料夾 也 能直接 找到裡面的檔案名稱)
將 搜尋 的結果顯示在
活頁薄  2  能 顯示 詳細資料(EX 檔案大小  修改日期 )
請問我該怎麼寫比較好
不知道要怎樣 讓 子資料夾裡面的檔案 也能 顯示

ivccav

这个问题，我很确定在论坛中能找到不需要改动的代码。

蓝桥玄霜

http://www.excelpx.com/thread-425053-1-1.html

蓝桥玄霜

1. Public k, kxm, txm, dxm
   
2. 
   
3. Sub main()
   
4. Dim fp As String, Arr, i&, Myr&
   
5. Dim Sht As Worksheet, sh As Worksheet, dic
   
6. Set dic = CreateObject("Scripting.Dictionary")
   
7. Set dxm = CreateObject("Scripting.Dictionary")
   
8. Application.ScreenUpdating = False
   
9. fp = ThisWorkbook.Path & ""
   
10. Call searfile(fp, ".jpg")
    
11. Set Sht = ActiveSheet
    
12. Myr = Sheet2.[d65536].End(xlUp).Row
    
13. Arr = Sheet2.Range("d1:d" & Myr)
    
14. For i = 2 To UBound(Arr)
    
15.     dic(Arr(i, 1)) = ""
    
16. Next
    
17. k = dic.keys
    
18. Application.ScreenUpdating = True
    
19. End Sub
    
20. Sub searfile(fp As String, fkey As String)
    
21. Dim Arr1() As String, i1 As Integer, i2 As Integer, fm, aa, xm$, nm$
    
22. If Right(fp, 1) <> "" Then fp = fp & ""
    
23. If Len(fkey) < 1 Then fkey = ".xls"
    
24. fm = Dir(fp, vbDirectory)
    
25. Do While fm <> ""
    
26.     If fm <> "." And fm <> ".." Then
    
27.         If (GetAttr(fp & fm) And vbDirectory) = vbDirectory Then
    
28.             i1 = i1 + 1
    
29.             ReDim Preserve Arr1(1 To i1)
    
30.             Arr1(i1) = fp & fm
    
31.         End If
    
32.         If Right(fm, 4) = fkey Then
    
33.             aa = Split(fp, "")
    
34.             xm = aa(UBound(aa) - 1)
    
35.             nm = Split(fm, ".")(0)
    
36.             dxm(xm) = dxm(xm) & nm & ","
    
37.         Else
    
38.             dxm(fm) = ""
    
39.         End If
    
40.     End If
    
41.     fm = Dir
    
42. Loop
    
43. For i2 = 1 To i1
    
44.   Call searfile(Arr1(i2), fkey)
    
45. Next
    
46. kxm = dxm.keys: txm = dxm.items
    
47. End Sub
    

复制代码

zero5708

蓝桥玄霜 发表于 2018-1-5 12:54

抱歉大哥  這樣我 路徑 要輸入在哪呢
可以用成 一個 按鈕   搜尋 這樣嗎  然我需要一次能同時抓到很多路徑 的名稱
我是新手  第一次碰這程式

ivccav

详见附件。点击按钮，选择目标文件夹，然后自动获取该文件夹下所有文件夹和文件，
并做成超链，用鼠标一点就能打开了。（效果图）




获取指定文件夹及其子文件夹下所有文件.zip (48.48 KB, 下载次数: 20)

2018-1-5 18:04 上传

点击文件名下载附件

ivccav

1. Sub allfiles()
   
2.     Set fso = CreateObject("scripting.filesystemobject")
   
3.     Set fdo = Application.FileDialog(msoFileDialogFolderPicker)
   
4.     If fdo.Show = -1 Then
   
5.         pth = fdo.SelectedItems(1)
   
6.     Else
   
7.         MsgBox "您没有选择文件夹！按『确定』键结束", vbCritical
   
8.         Exit Sub
   
9.     End If
   
10.     With ActiveSheet
    
11.     .UsedRange.ClearContents
    
12.     .Cells(1, 1) = "文件名称"
    
13.     .Cells(1, 2) = "文件大小"
    
14.     .Cells(1, 3) = "修改日期"
    
15.     .Cells(1, 4) = "文件位置"
    
16.     Getfd (pth)
    
17.     '做成超链
    
18.     r = .Range("d" & Rows.Count).End(3).Row
    
19.     If r > 1 Then
    
20.         Set rng = .Range("d2:d" & r)
    
21.         For Each c In rng
    
22.             .Hyperlinks.Add Anchor:=c, Address:=c.Value
    
23.         Next
    
24.     End If
    
25.     End With
    
26.     Set fso = Nothing
    
27.     Set fdo = Nothing
    
28.     Set rng = Nothing
    
29.     MsgBox "文件已全部获取！点『确定』键结束"
    
30. End Sub
    
31. Sub Getfd(ByVal pth)
    
32.     Set fso = CreateObject("scripting.filesystemobject")
    
33.     Set ff = fso.getfolder(pth)
    
34.     For Each f In ff.Files
    
35.         Cells(Rows.Count, 1).End(3).Offset(1) = f.Name
    
36.         Cells(Rows.Count, 2).End(3).Offset(1) = FormatNumber(f.Size / 1048576, 2) & "MB"
    
37.         Cells(Rows.Count, 3).End(3).Offset(1) = f.DateLastModified
    
38.         Cells(Rows.Count, 4).End(3).Offset(1) = f
    
39.     Next f
    
40.     For Each fd In ff.subfolders
    
41.         Getfd (fd)
    
42.     Next fd
    
43. End Sub

复制代码

zero5708

ivccav 发表于 2018-1-5 18:10

謝謝大大  能用了 但是
Sub allfiles()
    Set fso = CreateObject("scripting.filesystemobject")
    Set fdo = Application.FileDialog(msoFileDialogFolderPicker)
    If fdo.Show = -1 Then
        pth = fdo.SelectedItems(1)
    Else
        MsgBox "您沒有選擇文件夾！按『確定』鍵結束", vbCritical
        Exit Sub
    End If
這一段應該是  選擇資料夾的部份把
能不能修改成 直接抓路徑 不用 在選擇呢
因為要同時 抓到很多路徑的檔案 做交叉比對
所以需要 可能A1 A2  A3 欄位   輸入路徑 名稱
直接就能抓取道路徑 名稱呢   

ivccav

zero5708 发表于 2018-1-5 20:30
謝謝大大  能用了 但是
Sub allfiles()
    Set fso = CreateObject("scripting.filesystemobject")

直接指定路径，就用pth = [a1]，假设在A1输入了路径。然后调用函数Getfd (pth)就行了

zero5708

ivccav 发表于 2018-1-5 21:14
直接指定路径，就用pth = [a1]，假设在A1输入了路径。然后调用函数Getfd (pth)就行了

感謝指導 目前程式碼 是這樣
Private Sub CommandButton1_Click()
Call allfiles
  End Sub
Sub allfiles()
Set fso = CreateObject("scripting.filesystemobject")
    pth = [a1]
     With ActiveSheet
    .UsedRange.ClearContents
    .Cells(1, 1) = "文件名稱"
    .Cells(1, 2) = "文件大小"
    .Cells(1, 3) = "修改日期"
    .Cells(1, 4) = "文件位置"
    Getfd (pth)
    '做成超鏈
    r = .Range("d" & Rows.Count).End(3).Row
    If r > 1 Then
    Worksheets(2).Select
        Set Rng = .Range("d2:d" & r)
        For Each c In Rng
            .Hyperlinks.Add Anchor:=c, Address:=c.Value
        Next
    End If
    End With
    Set fso = Nothing
    Set fdo = Nothing
    Set Rng = Nothing
    MsgBox "文件已全部獲取！點『確定』鍵結束"
  End Sub
  
Sub Getfd(ByVal pth)
    Set fso = CreateObject("scripting.filesystemobject")
    Set ff = fso.getfolder(pth)
    For Each f In ff.Files
        Cells(Rows.Count, 1).End(3).Offset(1) = f.Name
        Cells(Rows.Count, 2).End(3).Offset(1) = FormatNumber(f.Size / 1048576, 2) & "MB"
        Cells(Rows.Count, 3).End(3).Offset(1) = f.DateLastModified
        Cells(Rows.Count, 4).End(3).Offset(1) = f
    Next f
    For Each fd In ff.subfolders
    Worksheets(2).Select
        Getfd (fd)
    Next fd
End Sub

我創了一個按鈕 去執行程式
想要 按下按鈕後  程式能執行到 活頁簿2
但是為何我加上worksheets(2).Select
結果只有
"文件名稱""文件大小""修改日期" "文件位置"
這4個標題到 活頁簿2  
其它結果還是在 第一頁呢