VBA

【VBA】フォルダ内のキーワードに一致したエクセルブックのすべてのシートに対して、指定したセルを集計シートに転記する

フォルダ内に大量に同じ様式のエクセルブックがあるとします。

起債計画書の様に事業毎に1つの様式を使用する場合、市町村によっては1つのブックにまとめたり、1事業につき1ブックにしたりまちまちだったりします。

その大量にある様式の必要な情報を集積するマクロになります。

山梨県都留市の起債計画書はこんな感じです。

ここから事業名、事業費、地方債額、概要を転記してみます。

セルアドレスはC2,F17, D24, B29です。

実行後はこんな感じです。

マクロを書いたブックの集計シートに転記されます。

Sub Main()
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual ' パフォーマンス向上のため計算を手動に設定

    Dim files As Collection
    Dim file As Variant

    On Error GoTo ErrorHandler

    ' フォルダ選択ダイアログを表示し、選択されたフォルダ内の
    ' 「起債計画書」を含むExcelファイルを取得
    Set files = GetExcelFilesMatchKeyword("起債計画書")
    For Each file In files
        Call GetValueFromExcelFiles(file)
    Next file

    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic ' 計算を自動に戻す
    
    MsgBox "処理が完了しました。"
    Exit Sub

ErrorHandler:
    MsgBox "エラーが発生しました：" & Err.Description
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    
End Sub

Sub GetValueFromExcelFiles(ByVal filePath As String)
    Dim wb As Workbook
    Dim ws As Worksheet
    Dim lastRow As Long ' 転記の最終行

    On Error GoTo ErrorHandler
    Set wb = Workbooks.Open(filePath)

    ' ブックのすべてのシートをループ
    For Each ws In wb.Worksheets

        ' 転記処理
        With ThisWorkbook.Worksheets("集計")

            ' D列をみて最終行を取得
            lastRow = .Cells(Rows.count, 4).End(xlUp).row

            .Cells(lastRow + 1, 3).Value = ws.Range("C2").Value ' 対象事業名
            .Cells(lastRow + 1, 4).Value = ws.Range("F17").Value ' 事業費
            .Cells(lastRow + 1, 5).Value = ws.Range("D24").Value ' 地方債
            .Cells(lastRow + 1, 6).Value = ws.Range("B29").Value ' 事業概要

            ' 事業概要が長い場合セルの高さを調整する
            .Rows(lastRow + 1).RowHeight = 30

        End With
    Next ws

    wb.Close SaveChanges:=False
    Exit Sub

ErrorHandler:
    MsgBox "エラーが発生しました：" & Err.Description
    If Not wb Is Nothing Then
        wb.Close SaveChanges:=False
    End If
    
End Sub

Function GetExcelFilesMatchKeyword(ByVal keyword As String) As Collection
    Dim folderPath As String
    Dim file As String
    Dim files As New Collection

    folderPath = SelectFolder()

    ' ユーザーがフォルダを選択しなかった場合は処理を終了
    If folderPath = "" Then Exit Function

    ' フォルダパスの末尾にバックスラッシュがない場合は追加
    If Right(folderPath, 1) <> "\" Then folderPath = folderPath & "\"

    ' 最初のファイルを検索
    file = Dir(folderPath & "*.xls*")

    ' 全ファイルをループ
    Do While file <> ""
        ' キーワードを含む場合にリストに追加
        If InStr(1, file, keyword) > 0 Then
            files.Add folderPath & file
        End If

        ' 次のファイルを検索
        file = Dir()
    Loop

    Set GetExcelFilesMatchKeyword = files
End Function
    
Function SelectFolder() As String
    With Application.fileDialog(msoFileDialogFolderPicker)
        .Title = "フォルダを選択してください"
        .AllowMultiSelect = False
        If .Show = -1 Then
            SelectFolder = .SelectedItems(1)
        End If
    End With
End Function

Main()では対象となるブック（ファイル名に起債計画書という文字列を含むブック）を取得して1つずつGetValueFromExcelFiles()に渡して処理をさせています。

自分で複数ファイルを選択するようにする、などMain()でブックの取得条件を変えて、業務に合うようにすることができます。

その場合はこの記事が参考になると思います。

関連記事【VBA】複数のエクセルファイルを読み込んでファイルパスを返すコード

GetValueFromExcelFiles()では1つのブックに対してすべてのシートを転記しています。

転記するセルは47行目から下を変更することでアレンジできます。

また、記載例など不要なシートがある場合は、転記処理の前にシートを限定する条件を追加してください。

具体的には40行目に以下のコードを追加します。

If ws.Name <> "記載例" Then

これで「記載例」というシートの転記を回避できます。

End Withの下に

End If

を入れるのをお忘れなく。

できればマクロでやらない方がいい

あらかじめ様式が決まっているのであれば、集計用のテーブルを定義しておいて、そこに必要な情報を集積、パワークエリで集計した方が絶対いいです。

セルの挿入が発生し、テーブルに集積できない場合や、もう様式を展開しちゃったよ～というときに仕方なくマクロを使ってください。

ChatGPTさんによる詳細解説

このコードは特定のキーワードを含むExcelファイルをフォルダから検索し、それらのファイルから特定のデータを抽出して集計シートに転記するプロセスを自動化するためのものです。それぞれの部分について説明します。

Sub Main()

  1. Application.ScreenUpdating = False
    • 画面更新をオフにして、マクロ実行中のスクリーンのちらつきを防ぎます。
  2. Application.Calculation = xlCalculationManual
    • Excelの計算モードを手動に設定して、マクロ実行中のパフォーマンスを向上させます。
  3. Dim files As Collection, Dim file As Variant
    • Excelファイルのパスを格納するコレクション files と、ループ中で使用する変数 file を宣言します。
  4. On Error GoTo ErrorHandler
    • エラーが発生した場合、ErrorHandler ラベルにジャンプします。
  5. Set files = GetExcelFilesMatchKeyword(“起債計画書”)
    • GetExcelFilesMatchKeyword 関数を使用して、”起債計画書” というキーワードを含むファイルのコレクションを取得します。
  6. For Each file In files
    • 取得したファイルコレクション内の各ファイルについてループを実行します。
  7. Call GetValueFromExcelFiles(file)
    • 各ファイルに対して GetValueFromExcelFiles サブルーチンを呼び出します。
  8. Application.ScreenUpdating = True, Application.Calculation = xlCalculationAutomatic
    • 画面更新と計算モードを元に戻します。
  9. MsgBox “処理が完了しました。”
    • 処理が終了したことをユーザーに通知します。

Sub GetValueFromExcelFiles(ByVal filePath As String)

  1. Dim wb As Workbook, Dim ws As Worksheet, Dim lastRow As Long
    • ワークブック wb、ワークシート ws、最後の行番号 lastRow の変数を宣言します。
  2. Set wb = Workbooks.Open(filePath)
    • 指定されたファイルパスのワークブックを開きます。
  3. For Each ws In wb.Worksheets
    • 開いたワークブックのすべてのシートについてループを実行します。
  4. lastRow = .Cells(Rows.count, 4).End(xlUp).row
    • 集計シートのD列から最後の行を取得します。
  5. .Cells(lastRow + 1, 3).Value = ws.Range(“C2”).Value など
    • 特定のセルからデータを取得し、集計シートの次の行に転記します。
  6. wb.Close SaveChanges:=False
    • 開いたワークブックを保存せずに閉じます。

Function GetExcelFilesMatchKeyword(ByVal keyword As String) As Collection

  1. Dim folderPath As String, Dim file As String, Dim files As New Collection
    • フォルダパス folderPath、ファイル名 file、ファイルパスのコレクション files を宣言します。
  2. folderPath = SelectFolder()
    • SelectFolder 関数を使用してユーザーが選択したフォルダパスを取得します。
  3. file = Dir(folderPath & “.xls“)
    • 指定されたフォルダ内のExcelファイルを検索します。
  1. Do While file <> “”
    • 検索したフォルダ内の全てのファイルに対してループを実行します。
  2. If InStr(1, file, keyword) > 0 Then
    • InStr 関数を使用して、各ファイル名に指定された keyword（この場合は”起債計画書”）が含まれているかどうかをチェックします。
  3. files.Add folderPath & file
    • キーワードを含むファイルが見つかった場合、そのファイルの完全パスを files コレクションに追加します。
  4. file = Dir()
    • 次のファイルを検索します。
  5. Loop
    • フォルダ内の全てのファイルが処理されるまでループを続けます。
  6. Set GetExcelFilesMatchKeyword = files
    • 関数の戻り値として、キーワードを含むファイルのコレクションを設定します。

Function SelectFolder() As String

  1. With Application.FileDialog(msoFileDialogFolderPicker)
    • フォルダ選択ダイアログを表示するための Application.FileDialog オブジェクトを使用します。
  2. .Title = “フォルダを選択してください”
    • ダイアログのタイトルを設定します。
  3. .AllowMultiSelect = False
    • 複数のフォルダ選択を不可に設定します。
  4. If .Show = -1 Then
    • ダイアログが表示され、ユーザーがフォルダを選択した場合の処理を定義します。
  5. SelectFolder = .SelectedItems(1)
    • 選択されたフォルダのパスを関数の戻り値として設定します。
  6. End With
    • With ブロックの終了を示します。

このコードは特定のキーワードを含むExcelファイルをフォルダから検索し、それらのファイルから特定のデータを集計シートに転記するプロセスを自動化します。このマクロは、多数のファイルにわたるデータ収集作業を効率化するのに役立ちます。

コメントを残す

メールアドレスが公開されることはありません。 ※ が付いている欄は必須項目です

CAPTCHA