0

1 つのフォルダー内のすべてのファイルのファイル名を返すことができるコードがあります。ただし、フォルダーを照会して、特定のファイル拡張子のすべてのファイル パスを返すように変更したいと考えています。(この場合は .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
4

1 に答える 1

0

関数を使用したもう 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

于 2013-01-29T16:53:16.670 に答える