ファイルリスト生成マクロ（エクセル）

概要

選択したフォルダ以下のファイル、フォルダ全てをカレントシートに記載するエクセルマクロ。

'
' このマクロを使用する時は、メニューから ツール(T)→ 参照設定(T)... を選び
' Microsoft Scripting Runtime を有効にすること
'

' 変数宣言を強制
Option Explicit

' フルパス中で選択フォルダ名が何文字目か
Dim myCurrentFolderSeparatePoint As Long

'
' ファイルリスト生成マクロ
' Date 17th Apr., 2019
' Programmed by Takeshi Sasaki
'

'
' 関数呼び出し
'
Sub myCall()
    
    ' 選択フォルダのフルパス
    Dim Path As String
    
    ' 画面更新の停止（マクロ高速化）
    Application.ScreenUpdating = False
    
    ' フォルダ選択ダイアログ
    With Application.FileDialog(msoFileDialogFolderPicker)
        
        If .Show = True Then
            
            ' フォルダ選択 → OK押下(True)
            Path = .SelectedItems(1)
        
        Else
            
            ' Cancel押下（False)
            Exit Sub
        
        End If
    
    End With
    
    ' ファイルリスト生成準備関数を呼び出し
    Call setFileList(Path)

End Sub


'
' ファイルリスト生成準備関数
'
Sub setFileList(searchPath)
    ' 変数宣言
    Dim startCell As Range
    Dim maxRow As Long
    Dim maxCol As Long
    
    ' searchPath の中から選択フォルダ名の直前の \ は何文字目か
    ' Ex. C:\hoge\fuga\foo ← 選択フォルダ foo のフルパス(searchPath)
    '     123456789+123456 ← bar 直前の \ は 13文字目
    myCurrentFolderSeparatePoint = InStrRev(searchPath, "\")
    
    ' カレントシート上でリストのスタート位置を指定する
    Set startCell = Cells(2, 2)
    startCell.Select
    
    ' カレントシート上の文字を全て消す
    maxRow = startCell.SpecialCells(xlLastCell).Row     ' 最終行
    maxCol = startCell.SpecialCells(xlLastCell).Column  ' 最終列
    With Range(startCell, Cells(maxRow, maxCol))
        .ClearContents              ' セル内容をクリア
        .Interior.ColorIndex = 0    ' 背景色を透明
    End With
    
    ' ファイルリスト生成関数を呼び出し
    Call getFileList(searchPath)
    
    ' リスト書き出し後にセルをスタート位置に戻す
    startCell.Select

End Sub


'
' ファイルリスト生成関数
'
Sub getFileList(searchPath)
    
    ' 引数 searchPath には選択フォルダのフルパスを代入
    
    ' File System Object を宣言
    Dim FSO As New FileSystemObject
    Dim objFiles As File
    Dim objFolders As Folder
    
    ' パスの文字列操作用テンポラリ
    Dim pathTemp As String
        
    ' パス中のセパレータ \ の数
    Dim separaterNum As Long
    
    ' 書き出しセルの横位置(Col)増分
    Dim incCol As Long
    
    
    ' サブフォルダがある時は自分自身を再帰呼出し
    For Each objFolders In FSO.GetFolder(searchPath).SubFolders
    
        Call getFileList(objFolders.Path)
    
    Next
    
    ' searchPath 内のファイル一覧を検索
    For Each objFiles In FSO.GetFolder(searchPath).Files
        
        ' objFiles → フルパス（文字列）
        
        ' 選択フォルダ以下のパス（文字列）
        ' ※forループ処理のため末尾に \ を意図的に追加している
        pathTemp = Right(objFiles, Len(objFiles) - myCurrentFolderSeparatePoint) & "\"
        
        ' pathTemp 中の \ の数
        separaterNum = Len(pathTemp) - Len(Replace(pathTemp, "\", "")) - 1
        
        ' フォルダ名、ファイル名を分割しながらセルに記入する
        For incCol = 0 To separaterNum
        
            ' pathTemp の左側から \ ごとに文字列を区切ってセルに記入
            ActiveCell.Offset(0, incCol).Value = Left(pathTemp, InStr(pathTemp, "\") - 1)
            
            ' ディレクトリ名のセルに着色する（ファイル名は無色）
            If incCol > 0 Then
                ActiveCell.Offset(0, incCol - 1).Interior.ColorIndex = 33 + incCol
            End If
            
            ' pathTemp の左端から \ までを削除して pathTemp に代入
            pathTemp = Right(pathTemp, Len(pathTemp) - InStr(pathTemp, "\"))
        
        Next incCol
        
        '次行のセルへ移動
        ActiveCell.Offset(1, 0).Select
        
    Next
    
End Sub

'
' EOF
'