VBA 類似dir的功能

millerch

請教諸位先進

Set oFolder = oFSO.GetFolder("D:\file\") 可顯示file目錄內所有的檔案
但若只要出現附檔名為*.xlsm之檔案，請問要如何改? 謝謝

Andy2483

回復 1# millerch


    謝謝前輩發表此主題
GetExtensionName 方法 ,會傳回包含路徑中最後一個元件的副檔名的字串。
https://learn.microsoft.com/zh-tw/office/vba/language/reference/user-interface-help/getextensionname-method

millerch

回復 2# Andy2483
謝謝前輩回覆
我VBA
' 建立目錄物件
Set oFolder = oFSO.GetFolder("D:\Dropbox\Swap\")
我不知如何產生類似
Set oFolder = oFSO.GetFolder("D:\Dropbox\Swap\*.xlsm的效果")   

我程式如下
Sub FM()
Dim oFSO As Object
Dim oFolder As Object
Dim oFile As Object
Dim i, j As Integer
RegexKill "D:\Dropbox\Swap\", "^[~]+.xlsm"
' 建立 FileSystemObject 物件
Set oFSO = CreateObject("Scripting.FileSystemObject")
' 建立目錄物件
Set oFolder = oFSO.GetFolder("D:\Dropbox\Swap\")
i = 4
j = 3
' 以迴圈列出所有檔案
For Each oFile In oFolder.Files
    If Left(oFile.name, 1) <> "~" Then
    Cells(i, j) = oFile.name              ' 檔案名稱
    j = j + 1
    'Cells(i, j) = oFile.Path              ' 檔案路徑
    ' j = j + 1
    Cells(i, j) = oFile.Size              ' 檔案大小（位元組）
     j = j + 1
    'Cells(i, j) = oFile.Type              ' 檔案類型
    ' j = j + 1
    Cells(i, j) = oFile.DateCreated       ' 檔案建立時間
     j = j + 1
    'Cells(i, j) = oFile.DateLastAccessed  ' 檔案上次存取時間
    ' j = j + 1
    Cells(i, j) = oFile.DateLastAccessed  ' 檔案上次修改時間

    i = i + 1
    j = 3
    End If

Next oFile
End Sub

Andy2483

回復 3# millerch


    謝謝前輩回復

Application.GetOpenFilename 方法 (Excel)

下載 (69.66 KB)

2023-1-4 11:43

Option Explicit
Sub TEST_OpenFile()
Dim FileFilter As String
Dim file_Open
FileFilter = "Excel Files(*. xlsm*),"
file_Open = Application.GetOpenFilename(FileFilter, 1, "請選擇文件")
'https://learn.microsoft.com/zh-tw/office/vba/api/excel.application.getopenfilename
If file_Open = False Then
   MsgBox "沒有選擇文件", vbOKOnly, "提示"
   Exit Sub
   Else
      Workbooks.Open Filename:=file_Open
End If
End Sub

Andy2483

回復 3# millerch


    如果是要資料夾檔案明細! 這是 准提部林前輩的方法

執行前:

下載 (94.37 KB)

2023-1-4 11:53

執行結果:

下載 (285.09 KB)

2023-1-4 11:51

Sub 清除()
Dim y&, z&
With ActiveSheet
     If .AutoFilterMode Then .AutoFilterMode = False
     y = .UsedRange.Rows.Count
     z = .[Uhead].Row + 1
     If y > z Then .Rows(z + 1 & ":" & y).EntireRow.Delete
     .Rows(z).ClearContents
     .[Uhead].Cells(2).Resize(1, 2) = Array("■", "本列請勿刪除")
End With
ActiveWindow.ScrollRow = 1
End Sub

Sub 載入檔案()
Dim MyPath, uPath, xD1, xD2, Urr, UU, OBJ, GFD, UFD, GFL, UFL, GG
Dim j&, Jm&, k&, Km&, x, Xm, ExName$, XX$, Arr, VV$, CCunt&, UCunt&
Call 清除:  MyPath = ThisWorkbook.FullName
uPath = [B1]
If uPath = "" Then MsgBox "路徑未輸入!": Exit Sub
If [B1] = "MyPath" Then uPath = ThisWorkbook.Path
If Dir(uPath, vbDirectory) = "" Then MsgBox "找不到路徑!": Exit Sub
If [B2] = "" Then MsgBox "副檔名未輸入!": Exit Sub
ExName = "," & UCase([B2]) & ",": If [B2] = "*.*" Then ExName = "1"
'----------------------------------------
[E4] = "～～正在擷取檔案明細，執行中可按ESC中止～～"
Application.EnableCancelKey = xlErrorHandler
Set OBJ = CreateObject("Scripting.FileSystemObject")
Set xD1 = CreateObject("Scripting.Dictionary")
Set xD2 = CreateObject("Scripting.Dictionary")
Urr = Array(uPath)
RE_GET:
On Error GoTo 999
For Each UU In Urr
    If Len(UU) < 3 Then
       Set GFD = OBJ.GetDrive(UU)
       VV = UCase(UU)
       Set UFD = GFD.RootFolder.SubFolders
       Set GFL = GFD.RootFolder.Files
    Else
       Set GFD = OBJ.GetFolder(UU)
       VV = GFD.Name:   SZ = 0
       Set UFD = GFD.SubFolders
       Set GFL = GFD.Files
    End If
    '-------------------------------
    k = 0: Xm = 0: UCunt = 0
    On Error Resume Next
       UCunt = GFL.Count '遇到〔System Volume Information〕會錯誤
    On Error GoTo 999
    If UCunt = 0 Then GoTo GET_SubFolder
    For Each GG In GFL
        If GG.Path = MyPath Then GoTo 101
        XX = UCase(OBJ.GetExtensionName(GG.Path))
        If XX = "" Then XX = "未知"
        If ExName = "1" Then j = 1 Else j = InStr(ExName, "," & XX & ",")
        If j = 0 Then GoTo 101
        Jm = Jm + 1: k = 1
        x = GG.Size / 1024: Xm = Xm + x
        xD1(Jm) = Array(GG.Name, XX, x, UU & "\")
        Application.StatusBar = "■■■正在擷取檔案名稱：(" & Jm & ")" & GG.Name
101: Next
    If k = 1 Then Jm = Jm + 1: xD1(Jm) = Array("＼" & VV & "＼", "", Xm, UU)
   '----------------------------------------------
GET_SubFolder:
    UCunt = 0
    On Error Resume Next
       UCunt = UFD.Count '遇到〔System Volume Information〕會錯誤
    On Error GoTo 999
    If UCunt > 0 Then
       For Each GG In UFD
           Km = Km + 1: xD2(Km) = GG.Path
       Next
    End If
Next
CCunt = CCunt + 1
If Val([C4]) > 0 Then If CCunt >= [C4] Then Km = 0
If Km > 0 Then Urr = xD2.items: xD2.RemoveAll: Km = 0: GoTo RE_GET
'---------------------------------------
If Jm = 0 Then MsgBox "找不到符合檔案！": GoTo 999
If Jm > Rows.Count - 1 Then MsgBox "檔案明細超過工作表可容納列數！": GoTo 999
Application.StatusBar = "■■■載入及整理資料中．．．．．"
ReDim Arr(Jm - 1, 3): k = 0
For Each UU In xD1.items
    Arr(k, 0) = UU(0): Arr(k, 1) = UU(1)
    Arr(k, 2) = UU(2): Arr(k, 3) = UU(3): k = k + 1
Next
With [Uhead].Cells(2, 1).Resize(Jm, 5)
     .Rows(1).Copy .Cells
     .Item(2).Resize(Jm, 4) = Arr
     .Sort Key1:=.Item(2), Order1:=xlAscending, Header:=xlNo
     .Sort Key1:=.Item(5), Order1:=xlAscending, Header:=xlNo
     .Columns(1).FormulaR1C1 = "=IF(RC[2]="""",HYPERLINK(RC[4],""■""),N(R[-1]C)+1)"
End With
[D1] = "=SUMIF(A7:A" & Jm + 6 & ","">0"",D7:D" & Jm + 6 & ")"
999: [E4] = "": Application.StatusBar = False
End Sub

Sub 載入資料夾()
Dim uPath, xD1, xD2, Urr, UU, OBJ, GFD, UFD, GG
Dim j&, Jm&, k&, Km&, Arr, VV$, SZ, CCunt&, UCunt&
Call 清除:   uPath = [B1]
If uPath = "" Then MsgBox "路徑未輸入!": Exit Sub
If [B1] = "MyPath" Then uPath = ThisWorkbook.Path
If Right(uPath, 1) = "\" Then uPath = Left(uPath, Len(uPath) - 1)
If Dir(uPath, vbDirectory) = "" Then MsgBox "路徑錯誤！": Exit Sub
'----------------------------------------
[E4] = "～～正在擷取資料夾，執行中可按ESC停止～～"
Application.EnableCancelKey = xlErrorHandler
Set OBJ = CreateObject("Scripting.FileSystemObject")
Set xD1 = CreateObject("Scripting.Dictionary")
Set xD2 = CreateObject("Scripting.Dictionary")
Urr = Array(uPath)
RE_GET:
On Error GoTo 999
For Each UU In Urr
    If Len(UU) < 3 Then
       Set GFD = OBJ.GetDrive(UU)
       VV = UCase(UU)
       SZ = GFD.TotalSize - GFD.FreeSpace
       Set UFD = GFD.RootFolder.SubFolders
    Else
       Set GFD = OBJ.GetFolder(UU)
       VV = GFD.Name: SZ = 0
       On Error Resume Next
          SZ = GFD.Size           '遇到〔System Volume Information〕會錯誤
       On Error GoTo 999
       Set UFD = GFD.SubFolders
    End If
   
    Jm = Jm + 1: xD1(Jm) = Array("＼" & VV & "＼", "Folder", SZ / 1024, UU)
    Application.StatusBar = "■■■正在擷取資料夾名稱：(" & Jm & ")" & VV
    UCunt = 0
    On Error Resume Next
       UCunt = UFD.Count '遇到〔System Volume Information〕會錯誤
    On Error GoTo 999
    If UCunt = 0 Then GoTo 101
    For Each GG In UFD
        Km = Km + 1: xD2(Km) = GG.Path
    Next
101: Next
CCunt = CCunt + 1
If Val([C4]) > 0 Then If CCunt >= [C4] Then Km = 0
If Km > 0 Then Urr = xD2.items: xD2.RemoveAll: Km = 0: GoTo RE_GET
'---------------------------------------
If Jm > Rows.Count - 1 Then MsgBox "資料夾數量超過工作表可容納列數！": GoTo 999
Application.StatusBar = "■■■載入及整理資料中．．．．．"
ReDim Arr(Jm - 1, 3)
For Each UU In xD1.items
    Arr(k, 0) = UU(0): Arr(k, 1) = UU(1)
    Arr(k, 2) = UU(2): Arr(k, 3) = UU(3): k = k + 1
Next
With [Uhead].Cells(2, 1).Resize(Jm, 5)
     .Rows(1).Copy .Cells
     .Item(2).Resize(Jm, 4) = Arr
     .Sort Key1:=.Item(5), Order1:=xlAscending, Header:=xlNo
     .Columns(1).FormulaR1C1 = "=IF(RC[3]="""","""",HYPERLINK(RC[4],""■""))"
End With
[D1] = "=D7"
999: [E4] = "": Application.StatusBar = False
End Sub

millerch

回復 5# Andy2483

謝謝詳細資料
我好好研究一下

samwang

回復 3# millerch

請測試看看，謝謝
Sub test()
Dim a, fs, f, fc, f1
Set fs = CreateObject("Scripting.FileSystemObject")
Range("c4").Select
With Application.FileDialog(msoFileDialogFolderPicker)
    .InitialFileName = "D:\"
    .Title = "======= 選擇資料夾 ========"
    .Show
    On Error GoTo EndSub:
    a = .SelectedItems(1)
End With
Set f = fs.GetFolder(a)
Set fc = f.Files
For Each f1 In fc
    With ActiveCell
        .Value = f1.Path
        .Offset(0, 1).Value = f1.Name
        .Offset(0, 2).Value = f1.Size
        .Offset(0, 3).Value = f1.Type
        .Offset(0, 4).Value = f1.DateCreated
        .Offset(0, 5).Value = f1.DateLastAccessed
        .Offset(1, 0).Select
    End With
Next
Set fs = Nothing
Set f = Nothing
Set fc = Nothing
EndSub:
End Sub

millerch

回復 7# samwang


   感謝大大

Emily

回復 1# millerch
借用 samwang 選取 dir 部份
列出你想要的 xlsm 檔

1. Private fso As Object
   
2. 
   
3. Public Sub ListAllXlsmFiles()
   
4. Dim foundFiles As New Collection
   
5. Dim foundFile As Variant
   
6. Dim DirPath As String
   
7. 
   
8. Set fso = CreateObject("Scripting.FileSystemObject")
   
9. Range("A1").Select
   
10. With Application.FileDialog(msoFileDialogFolderPicker)
    
11.     .InitialFileName = "G:\"
    
12.     .Title = "======= 選擇資料夾 ========"
    
13.     .Show
    
14.     On Error GoTo EndSub
    
15.     DirPath = .SelectedItems(1)
    
16. End With
    
17. 
    
18. FindAllFiles DirPath, "xlsm", foundFiles
    
19. 
    
20. For Each foundFile In foundFiles
    
21.     With ActiveCell
    
22.         .Value = foundFile
    
23.         .Offset(1, 0).Select
    
24.     End With
    
25. Next foundFile
    
26. EndSub:
    
27. End Sub
    
28. 
    
29. Private Sub FindAllFiles(parentFolder As String, extension As String, foundFiles As Collection)
    
30. Dim thisFolder As Object
    
31. Dim subFolder As Object
    
32. Dim thisFile As Object
    
33. Dim testObject As Object
    
34. 
    
35. On Error Resume Next
    
36. Set thisFolder = fso.GetFolder(parentFolder)
    
37. 
    
38. Err.Clear
    
39. Set testObject = thisFolder.Files
    
40. If Err.Number = 0 Then
    
41.     For Each thisFile In thisFolder.Files
    
42.         If LCase(thisFile.Name) Like "*." & LCase(extension) Then
    
43.             foundFiles.Add thisFile.Path
    
44.         End If
    
45.     Next thisFile
    
46. End If
    
47. 
    
48. Err.Clear
    
49. Set testObject = thisFolder.SubFolders
    
50. If Err.Number = 0 Then
    
51.     For Each subFolder In thisFolder.SubFolders
    
52.         FindAllFiles subFolder.Path, extension, foundFiles
    
53.     Next subFolder
    
54. End If
    
55. End Sub

複製代碼

HTGeorge

我是這樣用的
Dim TPP(300, 2) As String
            Dim myFolder1 As String, myFile1 As String
                       myFolder1 = "D:\查詢用資料庫\"
                       myFile1 = Dir(myFolder1)  ‘指定目錄
                J = 0
                Do While myFile1 <> ""
                    If myFile1 Like "*.xlsm" Or myFile2 Like "*.XLSM" Then
                        TPP(M, 0) = "舊版"
                        TPP(M, 1) = myFile1
                        TPP(M, 2) = " D:\查詢用資料庫\" & myFile1
                        M = M + 1
                    End If
                    myFile1 = Dir()
                    J = J + 1
                Loop
            List_item.List() = TPP  ‘List_item 為列表物件