Board logo

標題: VBA 類似dir的功能 [打印本頁]
作者: millerch    時間: 2023-1-1 18:32     標題: VBA 類似dir的功能

請教諸位先進

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

回復 1# millerch


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

回復 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    時間: 2023-1-4 11:44

回復 3# millerch


    謝謝前輩回復

Application.GetOpenFilename 方法 (Excel)
[attach]35723[/attach]

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    時間: 2023-1-4 11:55

回復 3# millerch


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

執行前:
[attach]35725[/attach]

執行結果:
[attach]35724[/attach]

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    時間: 2023-1-4 14:20

回復 5# Andy2483

謝謝詳細資料
我好好研究一下
作者: samwang    時間: 2023-1-5 12:37

回復 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    時間: 2023-1-7 18:45

回復 7# samwang


   感謝大大
作者: Emily    時間: 2023-1-9 21:14

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

  3. Public Sub ListAllXlsmFiles()
  4. Dim foundFiles As New Collection
  5. Dim foundFile As Variant
  6. Dim DirPath As String

  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

  18. FindAllFiles DirPath, "xlsm", foundFiles

  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

  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

  35. On Error Resume Next
  36. Set thisFolder = fso.GetFolder(parentFolder)

  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

  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    時間: 2023-1-18 11:52

我是這樣用的
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 為列表物件
作者: HTGeorge    時間: 2023-1-18 11:53

我是這樣用的
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 為列表物件
作者: millerch    時間: 2023-1-21 16:21

回復 10# HTGeorge


    寫得很簡潔，謝謝大大



歡迎光臨 麻辣家族討論版版 (http://forum.twbts.com/)