エクセル実践編：フォルダ内のファイルをリスト化＆ハイパーリンク設定からデータ取得までの自動化

Option Explicit

'■ Enum設定
Public Enum 行
    パス記載 = 2
    ファイル転記説明 = 4
    ファイル名開始
End Enum

Public Enum 列
    附番 = 1
    ファイル名記載
    パス記載
    レ点 = 6
End Enum

Public Sub ファイル名を取得()
    Dim folderPath As String
    Dim filePath As String
    Dim fileName As String
    Dim i As Long
    Dim lastRow As Long
    Dim MyRange As Range  '//セルの罫線に使用

    '// 初期設定
    '※ファイルダイアログの初期で表示すされるパス
    Const initPath As String = "C:\サンプル"
    
    '// エラー処理
    On Error GoTo ErrLabel
    
    '// ダイアログでフォルダパス取得
    folderPath = get_folderPath(initPath)
    
    '//最終行取得
    lastRow = Cells(Rows.Count, 列.附番).End(xlUp).Row
    
    '// データ削除
    Call delete_Data(lastRow)

    '// 指定フォルダー内のファイルを取得
    filePath = folderPath & "\*.xls*"
    fileName = Dir(filePath, vbHidden Or vbReadOnly)
    
    i = 0
    Do While fileName <> ""
            Cells(行.ファイル名開始 + i, 列.附番) = i + 1 '//附番を記載
            'Cells(行.ファイル名開始 + i, 列.ファイル名記載) = fileName '//ファイル名を記載
            Cells(行.ファイル名開始 + i, 列.レ点) = "レ" '//「レ」を記載

            Set MyRange = Cells(行.ファイル名開始 + i, 列.レ点) '//「レ」を記載するセルの情報を変更
                    MyRange.HorizontalAlignment = xlCenter
                    MyRange.BorderAround LineStyle:=xlContinuous
                    MyRange.Borders.Weight = xlMedium
                    MyRange.Borders.Color = RGB(255, 192, 0)  '//罫線の色
                    MyRange.Interior.Color = RGB(255, 255, 204)  '//セルの色

            ActiveSheet.Hyperlinks.Add anchor:=Cells(行.ファイル名開始 + i, 列.ファイル名記載), _
                                                         Address:=folderPath & "\" & fileName, _
                                                         TextToDisplay:=fileName  '//ハイパーリンク設定
            i = i + 1
            fileName = Dir()
    Loop

    '//再度、最終行取得
    lastRow = Cells(Rows.Count, 列.附番).End(xlUp).Row
    
    '//抜き出したエクセルを並び替え
    Range(Cells(行.ファイル名開始, 列.ファイル名記載), Cells(lastRow, 列.レ点)) _
            .Sort key1:=Cells(行.ファイル名開始, 列.ファイル名記載), order1:=xlAscending

    '// 検索用の「レ」をドロップダウンにする
    Range(Cells(行.ファイル名開始, 列.レ点), Cells(lastRow, 列.レ点)) _
            .Validation.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Formula1:="レ"
    
    Exit Sub

ErrLabel:
        Dim msg As String
        msg = "エラー発生: " & Err.Source & vbCrLf & _
                    "エラー番号: " & Err.Number & vbCrLf & _
                    "エラー内容: " & Err.Description & vbCrLf
        MsgBox (msg)

End Sub

Private Sub delete_Data(ByVal lastRow As Long)
    
    If lastRow <> Cells(行.ファイル転記説明, 列.附番).Row Then
            Range(Cells(行.ファイル名開始, 列.附番), Cells(lastRow, 列.レ点)).Clear
    Else
            Columns(Cells(行.ファイル名開始, 列.レ点).Column).Clear
    End If
    
End Sub

Private Function get_folderPath(ByVal initPath As String) As String
    
    With Application.FileDialog(msoFileDialogFolderPicker)
                .InitialFileName = initPath
                .AllowMultiSelect = False

                .Title = "フォルダの選択"
        If .Show = True Then
                'Cells(行.パス記載, 列.パス記載) = .SelectedItems(1) '//ファイル転記箇所が変更となった際はこちらも変更をすること
                ActiveSheet.Hyperlinks.Add anchor:=Cells(行.パス記載, 列.パス記載), _
                                                         Address:=.SelectedItems(1), _
                                                         TextToDisplay:=.SelectedItems(1)
                
                get_folderPath = .SelectedItems(1)
        End If
    End With
End Function

Option Explicit

Public Sub 別エクセルのデータ取得()
    Dim Ws As Worksheet
    Dim Arr
    Dim folderPath As String
    Dim filePath As String
    Dim fileName As String
    Dim firstRow As Long, lastRow As Long
    Dim i As Long, j As Long
    
    '//初期設定
    Const init_fileName = "管理シート"
    
    With Sheets(init_fileName)
            
            If .Cells(行.ファイル名開始, 列.附番) = "" Then
                    MsgBox ("データがありません。" & vbCrLf & "ファイルを取得して下さい。")
                    Exit Sub
            End If
            
            firstRow = .Cells(行.ファイル名開始, 列.レ点).Row
            lastRow = .Cells(Rows.Count, 列.レ点).End(xlUp).Row
            folderPath = .Cells(行.パス記載, 列.パス記載) & "\"
            
            Call delete_Sheet(init_fileName)  '//シートを消す
            
            j = 0
            For i = firstRow To lastRow
                    If .Cells(i, 列.レ点) <> "レ" Then GoTo Continue
                    
                    fileName = .Cells(i, 列.ファイル名記載)
                    filePath = folderPath & fileName
                    
                    Arr = get_Arr(filePath)  '// 配列にファイル情報を取得
                    
                    Call create_Sheet(init_fileName, fileName)
                    
                    With Sheets(Sheets.Count)
                            Range(.Cells(1, 1), .Cells(UBound(Arr, 1), UBound(Arr, 2))) = Arr
                    End With
Continue:
            Next i
            .Select
    End With
End Sub

Private Sub delete_Sheet(ByVal init_fileName As String)
    Dim Ws As Worksheet
    
    Application.DisplayAlerts = False
    
    For Each Ws In ThisWorkbook.Sheets
            If Ws.Name <> init_fileName Then
                    Ws.Delete
            End If
    Next Ws

    Application.DisplayAlerts = True
End Sub

Private Function get_Arr(ByVal filePath As String)
    Dim Wb As Workbook
    
    Application.ScreenUpdating = False
    
    Set Wb = Workbooks.Open(fileName:=filePath, ReadOnly:=True)  '//ファイルを開く
    get_Arr = Wb.Sheets(1).Range("A1").CurrentRegion  '//表を取得
    Wb.Close SaveChanges:=False  '//ファイルを閉じる
    
    Application.ScreenUpdating = True
End Function

Private Sub create_Sheet(ByVal init_fileName As String, ByVal fileName As String)
    Dim Ws As Worksheet
    Dim newWs As Worksheet
    Dim file As String
    
    file = Mid(fileName, 1, InStr(fileName, ".") - 1)  '//拡張子を除いたものをシート名にする
    
    Set newWs = Sheets.Add(After:=Worksheets(Worksheets.Count))
    newWs.Name = file
End Sub