vba - 如何返回一个文件夹中所有文件的文件路径？这是用于 Excel VBA

Question

我有代码可以让我返回单个文件夹中所有文件的文件名。但是，我想修改它以查询文件夹并返回特定文件扩展名的所有文件路径。（在这种情况下 .run 文件）

任何帮助，将不胜感激！提前致谢。

        Option Explicit 

Sub GetFileNames() 

Dim xRow As Long 
Dim xDirect$, xFname$, InitialFoldr$ 

InitialFoldr$ = "G:\" '<<< Startup folder to begin searching from

       With Application.FileDialog(msoFileDialogFolderPicker) 
         .InitialFileName = Application.DefaultFilePath & "\" 
          .Title = "Please select a folder to list Files from" 
           .InitialFileName = InitialFoldr$ 
             .Show 
              If .SelectedItems.Count <> 0 Then 
                 xDirect$ = .SelectedItems(1) & "\" 
                 xFname$ = Dir(xDirect$, 7) 
                  Do While xFname$ <> "" 
                  ActiveCell.Offset(xRow) = xFname$ 
                  xRow = xRow + 1 
                   xFname$ = Dir 
              Loop 
          End If 
       End With 
   End Sub 

Answer 1

使用Dir函数的另一种方法：

Sub FilePaths()

Dim FileName As String
Dim FileMask As String
Dim InputFolder As String
Dim PathsArray() As String
Dim OutputRange As Range

InputFolder = "D:\DOCUMENTS\"
FileMask = "*.xls?"
Application.ScreenUpdating = False

FileName = Dir(InputFolder & FileMask)
ReDim PathsArray(0)
ThisWorkbook.ActiveSheet.Range("A1").CurrentRegion.ClearContents

Do While FileName <> ""
    PathsArray(UBound(PathsArray)) = InputFolder & FileName
    ReDim Preserve PathsArray(UBound(PathsArray) + 1)
    FileName = Dir
Loop

ReDim Preserve PathsArray(UBound(PathsArray))

Set OutputRange = ThisWorkbook.Sheets(1).Range("A1:A" & (UBound(PathsArray)))
OutputRange = WorksheetFunction.Transpose(PathsArray)
ThisWorkbook.ActiveSheet.Range("A1").CurrentRegion.Columns.AutoFit

Application.ScreenUpdating = True

MsgBox UBound(PathsArray) & " file(s) listed from folder:" & vbNewLine & InputFolder

End Sub

应定义源路径和文件掩码（允许使用通配符）。 *?

示例文件可用：https ://www.dropbox.com/s/j55p8otdiw67i7q/FilePaths.xlsm