Excel VBA: フォルダ内にあるファイルのパスを取得

Get-ChildItemコマンドレットの結果をクリップボード経由でワークシートに貼り付けたほうが早いけど、Excel VBAを使用しての方法を考える。

# PowerShell 5.1, Windows 11 (2024年4月頃)
$fileInfos = Get-ChildItem -File -Force -Recurse -Depth 1 -LiteralPath "${env:USERPROFILE}\Desktop"
$fileInfos.FullName | Sort-Object | Set-Clipboard

' Excel 2019, Windows 11 (2024年4月頃)

' 参照設定
' Microsoft Office 16.0 Object Library
' Microsoft Scripting Runtime

Option Explicit

Public Sub GetFilePath(ByRef paths As VBA.Collection, ByRef folder As Scripting.Folder, ByVal depth As Long)
  Dim f As Scripting.File
  Dim d As Scripting.Folder

  If depth < 0 Then
    Exit Sub
  End If

  On Error GoTo ErrorHandler

  For Each f In folder.Files
    Call paths.Add(Item:=f.Path)
  Next f

  For Each d In folder.SubFolders
    Call GetFilePath(paths, d, depth - 1)
  Next d

  Exit Sub

ErrorHandler:
  Debug.Print folder.Path
  Debug.Assert False

End Sub

Public Sub Main()
  Dim fso As Scripting.FileSystemObject
  Dim dlg As Office.FileDialog
  Dim fld As Scripting.Folder
  Dim paths As VBA.Collection
  Dim depth As Long
  Dim arr2dPath() As String
  Dim sht As Excel.Worksheet
  Dim rng As Excel.Range
  Dim i As Long

  ' FileSystemObject
  Set fso = VBA.Interaction.CreateObject(Class:="Scripting.FileSystemObject")

  ' FolderPicker
  Set dlg = Excel.Application.FileDialog(FileDialogType:=Office.MsoFileDialogType.msoFileDialogFolderPicker)
  dlg.Title = "フォルダ選択"
  dlg.InitialFileName = VBA.Interaction.Environ(Expression:="USERPROFILE") & "\Desktop\"

  If dlg.Show = 0 Then
    Call Err.Raise(Number:=513, Description:="フォルダが選択されていません")
    Exit Sub
  End If

  ' Folderオブジェクト
  Set fld = fso.GetFolder(FolderPath:=dlg.SelectedItems.Item(1))

  ' ファイルのパスを入れるコレクション
  Set paths = New VBA.Collection

  ' InputBoxメソッドで再帰の深さを入力
  depth = Excel.Application.InputBox(Prompt:="depth", Title:="再帰の深さ", Default:=1, Type:=1)

  ' ファイルのパスを取得
  Call GetFilePath(paths, fld, depth)

  If paths.Count = 0 Then
    Call Err.Raise(Number:=514, Description:="ファイルがありません")
    Exit Sub
  End If

  ' セルに値を設定するための2次元配列
  ReDim arr2dPath(1 To paths.Count, 1 To 1)

  ' コレクションから2次元配列にコピー
  For i = 1 To UBound(arr2dPath, 1) Step 1
    arr2dPath(i, 1) = paths.Item(i)
  Next i

  ' ワークシートのセル範囲を取得
  Set sht = Excel.Application.ActiveWindow.ActiveSheet
  Set rng = sht.Range(sht.Cells.Item(1, 1), sht.Cells.Item(UBound(arr2dPath, 1), 1))

  ' 2次元配列の値をセル範囲の値に設定
  rng.Value2 = arr2dPath

  ' 並べ替え
  Call rng.Sort( _
    Key1:=rng.Columns.Item(1), _
    Order1:=Excel.XlSortOrder.xlAscending, _
    Header:=Excel.XlYesNoGuess.xlNo, _
    MatchCase:=False, _
    Orientation:=Excel.XlSortOrientation.xlSortColumns, _
    SortMethod:=Excel.XlSortMethod.xlPinYin, _
    DataOption1:=Excel.XlSortDataOption.xlSortNormal _
  )
End Sub