指定フォルダ内(サブフォルダ含む)のPDFファイル名を取得、シートAのセルA1から行方向に出力し、ファイル名順に並び替える

Sub prcOutputPDFNamesAndSort()
    ' 機能概要: 指定フォルダ内(サブフォルダ含む)のPDFファイル名を取得し、
    '           シートAのセルA1から行方向に出力し、ファイル名順に並び替える
    ' 引数: なし
    ' 備考: FileSystemObjectを使用

    Dim fso As FileSystemObject
    Dim folder As Folder
    Dim file As file
    Dim strFolderPath As String
    Dim ws As Worksheet
    Dim row As Integer
    Dim pdfFiles As Collection

    Set fso = New FileSystemObject
    Set pdfFiles = New Collection
    strFolderPath = "C:\FolderA" ' ここにフォルダのパスを指定
    Set folder = fso.GetFolder(strFolderPath)
    Set ws = ThisWorkbook.Sheets("SheetA") ' シート名を指定
    row = 1

    ' PDFファイル名をコレクションに追加
    Call AddPDFFiles(folder, pdfFiles)

    ' PDFファイル名をシートに出力
    For Each file In pdfFiles
        ws.Cells(row, 1).Value = file.Name
        row = row + 1
    Next file

    ' ファイル名順に並び替え
    With ws.Sort
        .SetRange ws.Range("A1:A" & pdfFiles.Count)
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

    ' オブジェクトの解放
    Set fso = Nothing
End Sub

' PDFファイル名をコレクションに追加する再帰関数
Sub AddPDFFiles(folder As Folder, pdfFiles As Collection)
    Dim subFolder As Folder
    Dim file As file

    ' フォルダ内のPDFファイルを追加
    For Each file In folder.Files
        If LCase(fso.GetExtensionName(file.Name)) = "pdf" Then
            pdfFiles.Add file
        End If
    Next file

    ' サブフォルダを処理
    For Each subFolder In folder.SubFolders
        AddPDFFiles subFolder, pdfFiles
    Next subFolder
End Sub

コメント