Получить список имен файлов в папке/каталоге с помощью Excel VBA

Question

У меня есть следующий код, который вытаскивает имена файлов из указанного мной каталога. Я нашел его в Интернете и модифицировал его для работы за то, что мне нужно.

Проблема в том, что я не хочу, чтобы это всплывающее окно с окном с просьбой выбрать папку - я хочу использовать указанную папку. Как я могу изменить этот код, чтобы мне не пришлось использовать это окно, или если я не могу его изменить, что я могу сделать с моей ситуацией?

Dim xRow As Long 
Dim xDirect$, xFname$, InitialFoldr$ 
InitialFoldr$ = "C:\Desktop" '<<< 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) = Left(xFname$, InStrRev(xFname$, ".") - 1) 
      xRow = xRow + 1 
      xFname$ = Dir 
     Loop 
    End If 
End With 

Answer 1

В итоге я полностью изменил свой код и не использовал старый код. Опять же, я нашел код в Интернете и модифицировал его для работы за то, что мне нужно.

Application.ScreenUpdating = False 
Application.Calculation = xlCalculationManual 

Dim FileArray() As Variant 
Dim FileCount As Integer 
Dim FileName As String 
Dim rng As Range 
Dim Idx As Integer 

FileCount = 0 
FileName = Dir("C:\Desktop") 

' Loop until no more matching files are found 
Do While FileName <> "" 
    FileCount = FileCount + 1 
    ReDim Preserve FileArray(1 To FileCount) 
    FileArray(FileCount) = FileName 
    FileName = Dir() 
Loop 
GetFileList = FileArray 
Set rng = ActiveCell 
For Idx = 0 To FileCount - 1 
    ActiveCell.Offset(Idx, 0).Value = Left(FileArray(Idx + 1), InStrRev(FileArray(Idx + 1), ".") - 1) 
Next Idx 

Application.Calculation = xlCalculationAutomatic 
Application.ScreenUpdating = True 

Answer 2

Это критическая часть кода:

xDirect$ = .SelectedItems(1) & "\" 
xFname$ = Dir(xDirect$, 7) 
Do While xFname$ <> "" 
    ActiveCell.Offset(xRow) = Left(xFname$, InStrRev(xFname$, ".") - 1) 
    xRow = xRow + 1 
    xFname$ = Dir 
Loop 

если изменить первую строку в этом блоке будет

xDirect$ = My_Path_With_Trailing_Slash 

вы можете указать любой путь, который вы хотите

Answer 3

В моем Excel-2010 пример Kelsius работает только с обратной (обратной) обратной косой чертой в имени каталога:

FileName = Dir ("C: \ Desktop \")

Это мой полный пример:

Public Sub ReadFileList() 
Dim bkp As String 

Dim FileArray() As Variant 
Dim FileCount As Integer 
Dim FileName As String 
Dim Idx As Integer 
Dim rng As Range 

    bkp = "E:\Flak\TRGRES\1\" 

    If bkp <> "" Then 
     FileCount = 0 
     FileName = dir(bkp) 

     Do While FileName <> "" 
      Debug.Print FileName 

      FileCount = FileCount + 1 
      ReDim Preserve FileArray(1 To FileCount) 
      FileArray(FileCount) = FileName 
      FileName = dir() 
     Loop 
    End If 
End Sub