【VBA】フォルダを選択してキーワードを含むエクセルの特定のシートの値を取得して転記する

【VBA】フォルダ内のキーワードを含むエクセルファイルリストを返すこのコードを利用して以下の処理をします。

1.選択したフォルダ内の「様式」を含むすべてのエクセルを取得
2.取得したエクセルの「集計」シートのA1の値を取得
3.A1の値をコードが書かれたエクセルファイルの「Sheet1」に転記

選択するフォルダはこんな感じになっていると想定しています。渋谷様式と新宿様式が取得されます。

取得したエクセルファイルの中身です。今回は取得したい情報はA1にあるとしています。

最後にコードが書かれたブックに転記します。

Sub test()
    
    Dim fileDialog As fileDialog
    Dim folderPath As String
    
    ' FileDialogオブジェクトの初期化
    Set fileDialog = Application.fileDialog(msoFileDialogFolderPicker)
    
    With fileDialog
    
        ' ダイアログのタイトル設定
        .Title = "フォルダを選択してください"
        
        ' ファイル選択ダイアログの表示
        If .Show = -1 Then
            folderPath = .SelectedItems(1)
        End If
        
        If folderPath = "" Then
            MsgBox "フォルダを選択してください"
        End If
        
    End With
    
    Set fileDialog = Nothing
    
    '配列の宣言
    Dim fileList As Variant
    ReDim fileslist(1 To 1)
    
    '指定したフォルダ内のエクセルファイルリストを取得
    fileList = GetMatchingExcelFiles(folderPath, "様式")
    
    Dim i As Long
    Dim wb As Workbook
    Dim lastRow As Long
    
    For i = LBound(fileList) To UBound(fileList)
        
        Set wb = Workbooks.Open(fileList(i))
        
        '最終行を取得
        lastRow = ThisWorkbook.Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row + 1
        
        'A1セルをコピー
        wb.Worksheets("集計").Range("A1").Copy
        
        'このブックのA列の最終行に貼り付け
        ThisWorkbook.Worksheets("Sheet1").Cells(lastRow, 1).PasteSpecial
        
        '保存せずに閉じる
        wb.Close SaveChanges:=False
        
    Next i
    
End Sub


Function GetMatchingExcelFiles(folderPath As String, keyword As String) As Variant
    '選択したフォルダ内のキーワードを含むエクセルファイルリストを返す
    
    Dim filesArray() As Variant
    Dim fileName     As String
    Dim i            As Long
    Dim fileCount    As Long

    ' フォルダ内のすべてのファイルを取得(.xlsx)
    fileName = Dir(folderPath & "\*.xlsx")

    ' マッチするファイルを格納するための配列を初期化
    ReDim filesArray(1 To 1)
    fileCount = 0

    ' キーワードに一致するファイルを配列に追加(.xls)
    fileName = Dir(folderPath & "\*.xls")
    Do While fileName <> ""
        If InStr(1, fileName, keyword, vbTextCompare) > 0 Then
            fileCount = fileCount + 1
            ReDim Preserve filesArray(1 To fileCount)
            filesArray(fileCount) = folderPath & "\" & fileName
        End If
        fileName = Dir()
    Loop

    ' マッチするファイルが存在しない場合は、空の配列を返す
    If fileCount = 0 Then
        GetMatchingExcelFiles = filesArray()
    Else
        GetMatchingExcelFiles = filesArray
    End If

End Function

Sub test()内の"様式"、"集計"、"Sheet1"、"A1"を修正してやりたい処理を実装してみてください。

ぱっと見便利そうですが、実際に使ってみるとエラーが出る場合が結構あります。

「様式」を含んでいるけど取得したくないエクセルや、「集計」シートがない場合などです。

エラーハンドリングの実装はメインのコーディングより面倒だったりするので、実際のところは対象となるエクセルが100個くらいであれば、【VBA】複数のエクセルファイルを選択してファイルパスを返すコードのように自分で選んであげる方がトータルで楽だったりします。

対象が1000個とかであれば頑張ってエラーハンドリングをしましょう。