VBA 類似dir的功能

1^# 跳轉到 »

發表於 2023-1-9 21:14 | 顯示全部帖子

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

Private fso As Object
Public Sub ListAllXlsmFiles()
Dim foundFiles As New Collection
Dim foundFile As Variant
Dim DirPath As String
Set fso = CreateObject("Scripting.FileSystemObject")
Range("A1").Select
With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = "G:\"
.Title = "======= 選擇資料夾 ========"
.Show
On Error GoTo EndSub
DirPath = .SelectedItems(1)
End With
FindAllFiles DirPath, "xlsm", foundFiles
For Each foundFile In foundFiles
With ActiveCell
.Value = foundFile
.Offset(1, 0).Select
End With
Next foundFile
EndSub:
End Sub
Private Sub FindAllFiles(parentFolder As String, extension As String, foundFiles As Collection)
Dim thisFolder As Object
Dim subFolder As Object
Dim thisFile As Object
Dim testObject As Object
On Error Resume Next
Set thisFolder = fso.GetFolder(parentFolder)
Err.Clear
Set testObject = thisFolder.Files
If Err.Number = 0 Then
For Each thisFile In thisFolder.Files
If LCase(thisFile.Name) Like "*." & LCase(extension) Then
foundFiles.Add thisFile.Path
End If
Next thisFile
End If
Err.Clear
Set testObject = thisFolder.SubFolders
If Err.Number = 0 Then
For Each subFolder In thisFolder.SubFolders
FindAllFiles subFolder.Path, extension, foundFiles
Next subFolder
End If
End Sub

複製代碼

靜思自在 : 小事不做、大事難成。