【Excel VBA配布】フォルダ内のファイル名を一覧取得｜マクロで効率化

Sub ProcessFilesAndFoldersInFolder_yellow()

    On Error GoTo ErrorHandler
    
    Dim FolderPath As String
    Dim OutputWorksheet As Worksheet
    Dim RowCounter As Long
    Dim lastValues As Object

    ' Turn off screen updating, automatic calculations and events.
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False

    ' Select the folder path from dialog box.
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "Select a Folder"
        .Show
        If .SelectedItems.Count > 0 Then
            FolderPath = .SelectedItems(1)
        Else
            ' If the user chooses cancel, stop the process.
            ' Reset Excel settings before exiting.
            Application.ScreenUpdating = True
            Application.Calculation = xlCalculationAutomatic
            Application.EnableEvents = True
            Exit Sub
        End If
    End With
    
    ' Set Sheet1 as the target.
    Set OutputWorksheet = ThisWorkbook.Sheets("Sheet1")
    Set lastValues = CreateObject("Scripting.Dictionary")
    
    RowCounter = 2 ' Start from second row
    
    ' List files and folders in the folder.
    Call ListMyFilesAndFolders(FolderPath, FolderPath, RowCounter, OutputWorksheet, lastValues)

    ' Write the selected folder path at first row
    OutputWorksheet.Cells(1, 1).Value = FolderPath

    ' Delete the old first row (now second row)
    OutputWorksheet.Rows(2).EntireRow.Delete

    ' Apply the color to the rightmost non-empty cell of each row.
    Call ColorizeRightmostCells(OutputWorksheet)

    ' Reset Excel settings at the end.
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
    
    ' Show completion message
    MsgBox "処理が完了しました。", vbInformation

ExitSub:
    Exit Sub

ErrorHandler:
    ' Reset Excel settings in case of error.
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
    MsgBox "エラーが発生しました。" & vbCrLf & "エラーメッセージ: " & Err.Description, vbCritical
    Resume ExitSub

End Sub

On Error GoTo ErrorHandler

Dim FolderPath As String ~ Dim lastValues As Object

Application.ScreenUpdating = False ~ Application.EnableEvents = False

With Application.FileDialog(msoFileDialogFolderPicker) ~ End With

Set OutputWorksheet = ThisWorkbook.Sheets("Sheet1") Set lastValues = CreateObject("Scripting.Dictionary")

Call ListMyFilesAndFolders(FolderPath, FolderPath, RowCounter, OutputWorksheet, lastValues)

OutputWorksheet.Cells(1, 1).Value = FolderPath OutputWorksheet.Rows(2).EntireRow.Delete

Call ColorizeRightmostCells(OutputWorksheet)

Application.ScreenUpdating = True ~ Application.EnableEvents = True

MsgBox "処理が完了しました。", vbInformation

ErrorHandler: ~ Resume ExitSub

Sub ColorizeRightmostCells(OutputWorksheet As Worksheet)
    Dim rng As Range
    Dim row As Range
    Dim cell As Range
    Dim lastCell As Range
    
    ' Define the range
    Set rng = OutputWorksheet.UsedRange
    
    ' Loop through each row
    For Each row In rng.Rows
        Set lastCell = Nothing
        ' Find the rightmost non-empty cell
        For Each cell In row.Cells
            If cell.Value <> "" Then
                Set lastCell = cell
            End If
        Next cell
        
        If Not lastCell Is Nothing Then
            ' Change the color of the rightmost non-empty cell
            lastCell.Interior.Color = RGB(255, 242, 204) ' equivalent to #FFF2CC
        End If
    Next row
End Sub

Dim rng As Range ~ Dim lastCell As Range

Set rng = OutputWorksheet.UsedRange

For Each row In rng.Rows ~ Next row

For Each cell In row.Cells ~ Next cell

If Not lastCell Is Nothing Then ~ End If

Sub ListMyFilesAndFolders(FolderPath As String, ParentFolderPath As String, ByRef RowCounter As Long, OutputWorksheet As Worksheet, ByRef lastValues As Object)

    Dim FSO As Object
    Dim Folder As Object
    Dim File As Object
    Dim SubFolder As Object
    Dim FilePathParts() As String
    Dim i As Long
    Dim j As Long
    Dim startCol As Integer
    Dim lastCol As Integer

    ' Create FileSystemObject.
    Set FSO = CreateObject("Scripting.FileSystemObject")

    ' Set the folder.
    Set Folder = FSO.GetFolder(FolderPath)

    ' Write the folder path itself first.
    FilePathParts = Split(Replace(FolderPath, ParentFolderPath & "\", ""), "\")
    WritePathParts FilePathParts, OutputWorksheet, RowCounter, lastValues

    ' Process each file in the folder.
    For Each File In Folder.Files
        ' Calculate relative path and write in the worksheet.
        FilePathParts = Split(Replace(File.Path, ParentFolderPath & "\", ""), "\")
        WritePathParts FilePathParts, OutputWorksheet, RowCounter, lastValues
    Next File

    ' Do the same process for each subfolder.
    For Each SubFolder In Folder.SubFolders
        Call ListMyFilesAndFolders(SubFolder.Path, ParentFolderPath, RowCounter, OutputWorksheet, lastValues)
    Next SubFolder
End Sub

Dim FSO As Object ~ Dim lastCol As Integer

Set FSO = CreateObject("Scripting.FileSystemObject")

Set Folder = FSO.GetFolder(FolderPath)

FilePathParts = Split(Replace(FolderPath, ParentFolderPath & "\", ""), "\") WritePathParts FilePathParts, OutputWorksheet, RowCounter, lastValues

For Each File In Folder.Files ~ Next File

For Each SubFolder In Folder.SubFolders ~ Next SubFolder

Sub WritePathParts(FilePathParts As Variant, OutputWorksheet As Worksheet, ByRef RowCounter As Long, ByRef lastValues As Object)
    Dim i As Long
    Dim j As Long
    Dim startCol As Integer
    Dim lastCol As Integer

    ' Output each part from A column.
    startCol = 1 ' A column
    For i = 0 To UBound(FilePathParts)
        OutputWorksheet.Cells(RowCounter, startCol + i).Value = FilePathParts(i)
    Next i

    lastCol = startCol + UBound(FilePathParts)

    ' If the same data continues in the same column, delete the data other than the top data.
    For j = startCol To lastCol
        If lastValues.exists(j) Then
            If OutputWorksheet.Cells(RowCounter, j).Value = lastValues(j) Then
                OutputWorksheet.Cells(RowCounter, j).ClearContents
            Else
                lastValues(j) = OutputWorksheet.Cells(RowCounter, j).Value
            End If
        Else
            lastValues(j) = OutputWorksheet.Cells(RowCounter, j).Value
        End If
    Next j

    RowCounter = RowCounter + 1
End Sub

Dim i As Long ~ Dim lastCol As Integer

startCol = 1 ' A column ~ Next i

For j = startCol To lastCol ~ Next j

RowCounter = RowCounter + 1