返回列表 上一主題 發帖

VBA 類似dir的功能

VBA 類似dir的功能

請教諸位先進

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

回復 1# millerch


    謝謝前輩發表此主題
GetExtensionName 方法 ,會傳回包含路徑中最後一個元件的副檔名的字串。
https://learn.microsoft.com/zh-tw/office/vba/language/reference/user-interface-help/getextensionname-method
看得懂是應該的,懂得應用才像學生,臉皮厚點學會更謹慎積極

TOP

回復 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

TOP

回復 3# millerch


    謝謝前輩回復

Application.GetOpenFilename 方法 (Excel)
開啟.jpg
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
看得懂是應該的,懂得應用才像學生,臉皮厚點學會更謹慎積極

TOP

回復 3# millerch


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

執行前:
2023-01-04_115153.JPG
2023-1-4 11:53


執行結果:
2023-01-04_114900.JPG
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
看得懂是應該的,懂得應用才像學生,臉皮厚點學會更謹慎積極

TOP

回復 5# Andy2483

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

TOP

回復 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

TOP

回復 7# samwang


   感謝大大

TOP

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

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

  6. Set fso = CreateObject("Scripting.FileSystemObject")
  7. Range("A1").Select
  8. With Application.FileDialog(msoFileDialogFolderPicker)
  9.     .InitialFileName = "G:\"
  10.     .Title = "======= 選擇資料夾 ========"
  11.     .Show
  12.     On Error GoTo EndSub
  13.     DirPath = .SelectedItems(1)
  14. End With

  15. FindAllFiles DirPath, "xlsm", foundFiles

  16. For Each foundFile In foundFiles
  17.     With ActiveCell
  18.         .Value = foundFile
  19.         .Offset(1, 0).Select
  20.     End With
  21. Next foundFile
  22. EndSub:
  23. End Sub

  24. Private Sub FindAllFiles(parentFolder As String, extension As String, foundFiles As Collection)
  25. Dim thisFolder As Object
  26. Dim subFolder As Object
  27. Dim thisFile As Object
  28. Dim testObject As Object

  29. On Error Resume Next
  30. Set thisFolder = fso.GetFolder(parentFolder)

  31. Err.Clear
  32. Set testObject = thisFolder.Files
  33. If Err.Number = 0 Then
  34.     For Each thisFile In thisFolder.Files
  35.         If LCase(thisFile.Name) Like "*." & LCase(extension) Then
  36.             foundFiles.Add thisFile.Path
  37.         End If
  38.     Next thisFile
  39. End If

  40. Err.Clear
  41. Set testObject = thisFolder.SubFolders
  42. If Err.Number = 0 Then
  43.     For Each subFolder In thisFolder.SubFolders
  44.         FindAllFiles subFolder.Path, extension, foundFiles
  45.     Next subFolder
  46. End If
  47. End Sub
複製代碼

TOP

我是這樣用的
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 為列表物件

TOP

        靜思自在 : 為自己找藉口的人永遠不會進步。
返回列表 上一主題