如何返回一个文件夹中所有文件的文件路径？ 这是用于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函数的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