VBA

【VBA】同じ様式を1つのエクセルブックのシートにまとめるときに、自動でリネームしてまとめる（キーワードで一撃編）

関連記事【VBA】同じ様式を1つのエクセルブックのシートにまとめるときに、自動でリネームしてまとめる

前回の記事では1つのエクセルブックを選択して、1番目のシートをマクロブックにコピーと自動リネームするコードを紹介しました。

今回は応用として、フォルダを選択してキーワードを含むエクセルブックのシートをコピーして自動リネームするコードを紹介します。

同じフォルダに各自治体の様式が入っていて、それを1つのブックにまとめて串刺し集計をするといった想定です。

Test()内でキーワードを「様式」と設定して実行すると

一撃でこの状態にできます。

Function SetSheetsName(ByVal fileName As String) As String
'-----------------------------------------
'
'ファイル名に自治体名が入っていれば
'01千代田区のようなシート名にする。
'
'-----------------------------------------
    
     If InStr(fileName, "千代田") > 0 Then
         SetSheetsName = "01千代田区"
     ElseIf InStr(fileName, "中央") > 0 Then
         SetSheetsName = "02中央区"
     ElseIf InStr(fileName, "港") > 0 Then
         SetSheetsName = "03港区"
     ElseIf InStr(fileName, "新宿") > 0 Then
         SetSheetsName = "04新宿区"
     ElseIf InStr(fileName, "文京") > 0 Then
         SetSheetsName = "05文京区"
     ElseIf InStr(fileName, "台東") > 0 Then
         SetSheetsName = "06台東区"
     ElseIf InStr(fileName, "墨田") > 0 Then
         SetSheetsName = "07墨田区"
     ElseIf InStr(fileName, "江東") > 0 Then
         SetSheetsName = "08江東区"
     ElseIf InStr(fileName, "品川") > 0 Then
         SetSheetsName = "09品川区"
     ElseIf InStr(fileName, "目黒") > 0 Then
         SetSheetsName = "10目黒区"
     ElseIf InStr(fileName, "大田") > 0 Then
         SetSheetsName = "11大田区"
     ElseIf InStr(fileName, "世田谷") > 0 Then
         SetSheetsName = "12世田谷区"
     ElseIf InStr(fileName, "渋谷") > 0 Then
         SetSheetsName = "13渋谷区"
     ElseIf InStr(fileName, "中野") > 0 Then
         SetSheetsName = "14中野区"
     ElseIf InStr(fileName, "杉並") > 0 Then
         SetSheetsName = "15杉並区"
     ElseIf InStr(fileName, "豊島") > 0 Then
         SetSheetsName = "16豊島区"
     ElseIf InStr(fileName, "北区") > 0 Then
         SetSheetsName = "17北区"
     ElseIf InStr(fileName, "荒川") > 0 Then
         SetSheetsName = "18荒川区"
     ElseIf InStr(fileName, "板橋") > 0 Then
         SetSheetsName = "19板橋区"
     ElseIf InStr(fileName, "練馬") > 0 Then
         SetSheetsName = "20練馬区"
     ElseIf InStr(fileName, "足立") > 0 Then
         SetSheetsName = "21足立区"
     ElseIf InStr(fileName, "葛飾") > 0 Then
         SetSheetsName = "22葛飾区"
     ElseIf InStr(fileName, "江戸川") > 0 Then
         SetSheetsName = "23江戸川区"
     'ファイル名に市町村名を含まない場合は末尾10文字をシート名にする
     Else
        'シート名に使えない文字列が含まれていれば削除する
        fileName = DeleteInvalidChars(fileName)
        SetSheetsName = Right(fileName, 10)
     End If
    
End Function

Function DeleteInvalidChars(fileName As String) As String
'シート名で扱えない文字列が含まれているときは削除する

    Dim invalidChars As String
    Dim i As Long

    invalidChars = "/\?*:[]"
    DeleteInvalidChars = fileName ' 元のファイル名を初期値として設定
    
    For i = 1 To Len(invalidChars)
        DeleteInvalidChars = Replace(DeleteInvalidChars, Mid(invalidChars, i, 1), "")
    Next i
    
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

Function GetExcelFilesWithKeyword(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 GetExcelFilesWithKeyword = files
End Function

Sub Test()

    Dim fileList As Collection
    Dim file As Variant
    Dim sourceWorkbook As Workbook
    Dim sourceSheet As Worksheet
    
    Set fileList = GetExcelFilesWithKeyword("様式")
    
    ' キーワードを含むブックの1番目のシートをコピー
    For Each file In fileList
        Set sourceWorkbook = Workbooks.Open(file)
        Set sourceSheet = sourceWorkbook.Sheets(1)
        sourceSheet.Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.count)
        sourceWorkbook.Close SaveChanges:=False

        '名前をセットする
        ThisWorkbook.Sheets(ThisWorkbook.Sheets.count).Name = SetSheetsName(file)
    Next file

End Sub

シートの名前の条件はSetSheetsName()、Test()でシートの選択やキーワード設定をしてください。

ChatGPTさんによる超詳細解説

Function SetSheetsName(ByVal fileName As String) As String

  1. Function SetSheetsName(ByVal fileName As String) As String
    • SetSheetsName 関数は、引数として与えられた fileName（ファイル名）をもとに、シートの名前を設定するための関数です。
  2. If InStr(fileName, “千代田”) > 0 Then
    • InStr 関数を使用して、fileName に “千代田” という文字列が含まれているかどうかをチェックします。含まれていれば、その位置は0より大きくなります。
  3. SetSheetsName = “01千代田区”
    • “千代田” が含まれている場合、シートの名前を “01千代田区” に設定します。

(以下の ElseIf ステートメントも同様に、異なる自治体名に対して異なるシート名を設定します。)

  1. Else
    • もし fileName に上記のいずれの自治体名も含まれていない場合、Else ブロックのコードが実行されます。
  2. fileName = DeleteInvalidChars(fileName)
    • DeleteInvalidChars 関数を使用して、fileName からシート名に使えない文字を削除します。
  3. SetSheetsName = Right(fileName, 10)
    • Right 関数を使用して、変更後の fileName の右側から10文字を取り出し、それをシート名として設定します。

Function DeleteInvalidChars(fileName As String) As String

  1. Dim invalidChars As String
    • シート名に使用できない文字を格納するための変数 invalidChars を宣言します。
  2. Dim i As Long
    • ループのカウンタとして使用する変数 i を宣言します。
  3. invalidChars = “/?*:[]”
    • シート名に使用できない文字を invalidChars に設定します。
  4. DeleteInvalidChars = fileName
    • 処理するファイル名を DeleteInvalidChars 関数の初期値として設定します。
  5. For i = 1 To Len(invalidChars)
    • invalidChars の各文字に対してループを行います。
  6. DeleteInvalidChars = Replace(DeleteInvalidChars, Mid(invalidChars, i, 1), “”)
    • Replace 関数を使用して、invalidChars に含まれる各文字を空文字列で置換します。
  7. Next i
    • ループの次のイテレーションに進みます。

Function SelectFolder() As String

  1. With Application.FileDialog(msoFileDialogFolderPicker)
    • Application.FileDialog を使用して、フォルダ選択のダイアログを開きます。ここでの msoFileDialogFolderPicker はフォルダを選択するためのダイアログを指定しています。
  2. .Title = “フォルダを選択してください”
    • ダイアログのタイトルを “フォルダを選択してください” に設定します。
  3. .AllowMultiSelect = False
    • 複数のフォルダを選択できないように設定します（一度に一つのフォルダのみ選択可能）。
  4. If .Show = -1 Then
    • ダイアログが表示され、ユーザーがフォルダを選択した場合の処理を定義します。.Show が -1 の場合は、ユーザーがフォルダを選択したことを意味します。
  5. SelectFolder = .SelectedItems(1)
    • 選択されたフォルダのパスを SelectFolder 関数の戻り値として設定します。
  6. End With
    • With ブロックの終了を示します。

Function GetExcelFilesWithKeyword(ByVal keyword As String) As Collection

  1. Dim folderPath As String
    • フォルダのパスを格納する変数 folderPath を宣言します。
  2. Dim file As String
    • ファイル名を格納する変数 file を宣言します。
  3. Dim files As New Collection
    • キーワードを含むファイルのパスを格納するための新しいコレクション files を作成します。
  4. folderPath = SelectFolder()
    • SelectFolder 関数を呼び出してユーザーが選択したフォルダのパスを取得し、folderPath に格納します。
  5. If folderPath = “” Then Exit Function
    • ユーザーがフォルダを選択しなかった場合（folderPath が空の場合）、関数から抜け出します。
  6. If Right(folderPath, 1) <> “” Then folderPath = folderPath & “”
    • folderPath の末尾がバックスラッシュ（\）でない場合、バックスラッシュを追加します。
  7. file = Dir(folderPath & “.xls“)
    • Dir 関数を使用して、指定されたフォルダパス（folderPath）内の “.xls” または “.xlsx” 拡張子を持つ最初のファイル名を取得します。
  8. Do While file <> “”
    • ファイル名が空でない間、ループを続けます。これによりフォルダ内の全てのExcelファイルをチェックできます。
  9. If InStr(1, file, keyword) > 0 Then
    • InStr 関数を使用して、ファイル名にキーワードが含まれているかをチェックします。含まれていれば、その位置は0より大きくなります。
  10. files.Add folderPath & file
    • キーワードを含むファイルの場合、そのパス（フォルダパス + ファイル名）を files コレクションに追加します。
  11. file = Dir()
    • Dir 関数を再度呼び出して、次のファイル名を取得します。
  12. Loop
    • Do While ループの終わりを示します。
  13. Set GetExcelFilesWithKeyword = files
    • files コレクションを関数の戻り値として設定します。これにより、キーワードを含む全てのExcelファイルのパスが格納されたコレクションを取得できます。

Sub Test()

  1. Dim fileList As Collection
    • fileList という名前のコレクション型の変数を宣言します。この変数は、キーワードを含むファイルのパスのコレクションを保存します。
  2. Dim file As Variant
    • file という名前の変数を宣言します。これは、後でコレクションから取り出される各ファイルのパスを保持するために使用されます。
  3. Set fileList = GetExcelFilesWithKeyword(“様式”)
    • GetExcelFilesWithKeyword 関数を呼び出して、”様式” というキーワードを含むファイルのパスのコレクションを fileList に設定します。
  4. For Each file In fileList
    • fileList コレクション内の各ファイルに対してループを行います。
  5. Set sourceWorkbook = Workbooks.Open(file)
    • Workbooks.Open メソッドを使用して、ループ内の現在の file（ファイルパス）を開き、sourceWorkbook に設定します。
  6. Set sourceSheet = sourceWorkbook.Sheets(1)
    • sourceWorkbook の最初のシートを sourceSheet に設定します。
  7. sourceSheet.Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
    • sourceSheet をコピーして、現在開いているワークブック（ThisWorkbook）の最後のシートの後に挿入します。
  8. sourceWorkbook.Close SaveChanges:=False
    • sourceWorkbook を保存せずに閉じます（SaveChanges:=False）。
  9. ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count).Name = SetSheetsName(file)
    • 新しく挿入されたシートの名前を SetSheetsName 関数を使用して設定します。この関数はファイル名（file）を基に適切なシート名を生成します。
  1. Next file
    • For Each ループのこの行は、コレクション fileList 内の次のアイテム（つまり次のファイル）に移動します。ループは fileList 内のすべてのアイテム（ファイル）に対して繰り返され、各ファイルに対して設定された処理（ワークブックを開いてシートをコピーし、名前を設定する）が実行されます。
  2. End Sub
    • この行は Sub Test() プロシージャの終わりを示します。このプロシージャは、特定のキーワードを含むExcelファイルを検索し、それらのファイルから最初のシートを現在開いているワークブックにコピーし、SetSheetsName 関数を用いて適切な名前を付ける処理を行います。

コメントを残す

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

CAPTCHA