すべての質問 質問投稿

Excel自動化：月別シート作成とブック生成の秘訣

SCORE: 2330
groups オープン

ブックAのシートdb140のAW列にあるセルの値から
同じフォルダ内へそのセルの値が名前となるブックを作成して
その作成されたブックへ
ブックAのシート年月A列から
月にあたる文字を取り出して
4,5,6,7,8,9,10,11,12,1,2,3というように
月別シートを作成したいのですが
Sheet1からSheet12までは作ることが出来ているのですが
Sheet1を4に、Sheet2を5...というように
シート名を変更する事ができません
指定の仕方(Active、This)とか変えてみたりしているのですが
どうしてか変更できません
どなたかご指導よろしくお願いします

年月シート
20254
20255
20256
20257
20258
20259
202510
202511
202512
20261
20262
20263

Sub test()

Dim wb As Workbook
Dim ws As Worksheet
Dim addWs As Worksheet
Dim nengetuWs As Worksheet
Dim newSheet As Worksheet
Dim cell As Range
Dim nengetuCell As Range
Dim thisPath As String
Dim wbName As String
Dim sheetName As String
Dim str As String
Dim str1 As String
Dim str2 As String
Dim nengetuWsLastRow As Long

Application.ScreenUpdating = False

Set ws = ThisWorkbook.Sheets("db140")
lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row

For Each cell In ws.Range("AW1:AW" & lastRow)
    If Not cell.Value = "" Then

        Set wb = Workbooks.Add
        thisPath = ThisWorkbook.path
        wbName = cell.Value & ".xlsm"

        wb.SaveAs fileName:=thisPath & "\" & wbName, FileFormat:=xlOpenXMLWorkbookMacroEnabled

        If Err.Number <> 0 Then
            Debug.Print "指定したブックが開いていません: " & wbName, vbExclamation
        Else
            Debug.Print "指定したブックををアクティブにしました: " & wbName, vbInformation

            Set nengetuWs = ThisWorkbook.Sheets("年月")

            nengetuWsLastRow = nengetuWs.Cells(nengetuWs.Rows.Count, 1).End(xlUp).Row

            For Each nengetuCell In nengetuWs.Range("A1:A" & nengetuWsLastRow)
                str = nengetuCell.Value
                str1 = Left(nengetuCell.Value, 4)
                    sheetName = Mid(str, Len(str1) + 1)
                        Set addWs = wb.Worksheets.Add(After:=Sheets(Worksheets.Count))
                        addWs.Name = sheetName
                        Debug.Print "addWs.Name = " & addWs.Name
            Next nengetuCell

         wb.Close (False)

        End If
    End If
Next 'cell

Application.ScreenUpdating = True

End Sub

2025/11/25 13:24

おっ、これは面白い挑戦ですね！ブックAから新しいブックをどんどん作って、さらに月ごとのシートも作りたいなんて、とってもクリエイティブ！😊 シート名の変更でちょっとつまづいているとのこと、大丈夫、一緒に解決策を見つけましょう！

いただいたコードと状況から、シート名の変更がうまくいかない原因は、新しいブックでシートを追加した直後に、そのシートの名前を変更しようとしている点にある可能性が高いです。

具体的には、wb.Worksheets.Add(After:=Sheets(Worksheets.Count)) で新しいシートを追加した後、その addWs という変数で参照しているシートの名前を addWs.Name = sheetName で変更しようとしていますね。

ここで考えられるのは、

  1. 追加されたシートがアクティブになっていない: Add メソッドで追加されたシートが、必ずしもアクティブなシートになるとは限りません。
  2. シート名に重複がある: もし、一度作成したシート名と同じ名前を再度付けようとするとエラーになります。

これらの点を踏まえて、いくつか改善案を提案しますね！

解決策の提案

1. アクティブなシートを明示的に指定する

シートを追加した後、そのシートをアクティブにしてから名前を変更する方法です。

Sub test_Revised1()

    Dim wb As Workbook
    Dim ws As Worksheet
    Dim addWs As Worksheet
    Dim nengetuWs As Worksheet
    Dim newSheet As Worksheet
    Dim cell As Range
    Dim nengetuCell As Range
    Dim thisPath As String
    Dim wbName As String
    Dim sheetName As String
    Dim str As String
    Dim str1 As String
    Dim nengetuWsLastRow As Long

    Application.ScreenUpdating = False

    Set ws = ThisWorkbook.Sheets("db140")
    Dim lastRow As Long ' lastRowの宣言を追加
    lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row

    For Each cell In ws.Range("AW1:AW" & lastRow)
        If Not cell.Value = "" Then

            Set wb = Workbooks.Add
            thisPath = ThisWorkbook.path
            wbName = cell.Value & ".xlsm"

            ' エラーハンドリングを改善
            On Error Resume Next ' エラーが発生しても続行
            wb.SaveAs fileName:=thisPath & "\" & wbName, FileFormat:=xlOpenXMLWorkbookMacroEnabled
            If Err.Number <> 0 Then
                MsgBox "ブックの保存中にエラーが発生しました: " & wbName & vbCrLf & Err.Description, vbCritical
                Err.Clear ' エラーをクリア
                wb.Close False ' 保存せずに閉じる
                GoTo NextCell ' 次のセルへ
            End If
            On Error GoTo 0 ' エラーハンドリングを元に戻す

            ' 新しいブックがアクティブになっていることを確認
            ' (Workbooks.Add で通常はアクティブになりますが、念のため)
            ' wb.Activate ' 必要であれば

            Set nengetuWs = ThisWorkbook.Sheets("年月")
            nengetuWsLastRow = nengetuWs.Cells(nengetuWs.Rows.Count, 1).End(xlUp).Row

            ' シートを削除してから追加する（重複を避けるため）
            ' まず、新しいブックの既存シートを削除する（初期シートSheet1など）
            Application.DisplayAlerts = False ' 警告メッセージを非表示
            For Each newSheet In wb.Worksheets
                If newSheet.Name <> "Sheet1" Then ' 初期シート以外を削除する場合
                    newSheet.Delete
                End If
            Next newSheet
            Application.DisplayAlerts = True ' 警告メッセージを再表示

            Dim sheetOrder As Variant
            sheetOrder = Array("4", "5", "6", "7", "8", "9", "10", "11", "12", "1", "2", "3") ' 月の順番を定義

            For i = 0 To UBound(sheetOrder)
                sheetName = sheetOrder(i)
                ' 新しいシートを追加し、そのシートを直接参照して名前を変更
                Set addWs = wb.Worksheets.Add(After:=wb.Sheets(wb.Sheets.Count))
                addWs.Name = sheetName ' ここで直接名前を変更
            Next i

            wb.Close True ' 保存して閉じる

        End If
NextCell:
    Next 'cell

    Application.ScreenUpdating = True
    MsgBox "処理が完了しました！ 🎉", vbInformation

End Sub

変更点とポイント:

  • sheetOrder 配列の導入: 月の順番を Array("4", "5", "6", "7", "8", "9", "10", "11", "12", "1", "2", "3") のように配列で定義しました。これにより、コードがより読みやすくなり、シート名の生成ロジックが明確になります。
  • wb.Worksheets.Add(After:=wb.Sheets(wb.Sheets.Count)): 新しいシートを追加する際に、After 引数で新しいブックの最後のシートの後ろに追加するように指定しています。
  • addWs.Name = sheetName: シートを追加した直後に、addWs 変数で参照しているシートの名前を直接変更しています。この方法が最も確実です。
  • 既存シートの削除: 新しいブックを作成するたびに、初期シート（Sheet1など）が残ってしまうので、それを削除する処理を追加しました。Application.DisplayAlerts = False で警告を非表示にしています。
  • エラーハンドリングの強化: On Error Resume Next と On Error GoTo 0 を使って、ブックの保存などでエラーが発生した場合に処理が止まらないようにしました。エラー発生時はメッセージを表示し、次の処理に進むようにしています。
  • lastRow の宣言: lastRow 変数が宣言されていなかったので、Dim lastRow As Long を追加しました。
  • wb.Close True: 変更を保存してブックを閉じるようにしました。

2. シート名の変更をループの後にまとめる

もし、シート名が重複する可能性が心配な場合は、一度シートを追加してから、後でまとめて名前を変更する方法もあります。ただし、今回のケースでは月の数字なので重複はしないはずです。

Sub test_Revised2()

    Dim wb As Workbook
    Dim ws As Worksheet
    Dim addWs As Worksheet
    Dim nengetuWs As Worksheet
    Dim newSheet As Worksheet
    Dim cell As Range
    Dim nengetuCell As Range
    Dim thisPath As String
    Dim wbName As String
    Dim sheetName As String
    Dim str As String
    Dim str1 As String
    Dim nengetuWsLastRow As Long
    Dim sheetNamesToChange As Collection ' シート名変更用のコレクション

    Application.ScreenUpdating = False

    Set ws = ThisWorkbook.Sheets("db140")
    Dim lastRow As Long
    lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row

    For Each cell In ws.Range("AW1:AW" & lastRow)
        If Not cell.Value = "" Then

            Set wb = Workbooks.Add
            thisPath = ThisWorkbook.path
            wbName = cell.Value & ".xlsm"

            On Error Resume Next
            wb.SaveAs fileName:=thisPath & "\" & wbName, FileFormat:=xlOpenXMLWorkbookMacroEnabled
            If Err.Number <> 0 Then
                MsgBox "ブックの保存中にエラーが発生しました: " & wbName & vbCrLf & Err.Description, vbCritical
                Err.Clear
                wb.Close False
                GoTo NextCell2
            End If
            On Error GoTo 0

            Set nengetuWs = ThisWorkbook.Sheets("年月")
            nengetuWsLastRow = nengetuWs.Cells(nengetuWs.Rows.Count, 1).End(xlUp).Row

            ' 新しいブックの初期シートを削除
            Application.DisplayAlerts = False
            For Each newSheet In wb.Worksheets
                If newSheet.Name <> "Sheet1" Then
                    newSheet.Delete
                End If
            Next newSheet
            Application.DisplayAlerts = True

            Set sheetNamesToChange = New Collection ' コレクションを初期化

            For Each nengetuCell In nengetuWs.Range("A1:A" & nengetuWsLastRow)
                str = nengetuCell.Value
                str1 = Left(nengetuCell.Value, 4)
                sheetName = Mid(str, Len(str1) + 1)

                ' シート名が既に存在するかチェック（念のため）
                Dim sheetExists As Boolean
                sheetExists = False
                On Error Resume Next
                Dim tempSheet As Worksheet
                Set tempSheet = wb.Sheets(sheetName)
                If Err.Number = 0 Then
                    sheetExists = True
                End If
                On Error GoTo 0

                If Not sheetExists Then
                    Set addWs = wb.Worksheets.Add(After:=wb.Sheets(wb.Sheets.Count))
                    ' 名前は後で変更するので、ここでは仮の名前（例: "TempSheet1", "TempSheet2"）を付けるか、
                    ' addWs をコレクションに格納しておき、後で名前を変更する
                    sheetNamesToChange.Add addWs, sheetName ' シートオブジェクトと新しい名前をキーとして格納
                Else
                    ' シート名が既に存在する場合はスキップ
                    Debug.Print "シート '" & sheetName & "' は既に存在します。スキップします。"
                End If
            Next nengetuCell

            ' コレクションを使ってシート名を一括変更
            Dim key As Variant
            Dim wsToRename As Worksheet
            For Each key In sheetNamesToChange.Keys
                Set wsToRename = sheetNamesToChange(key)
                wsToRename.Name = key
            Next key

            wb.Close True

        End If
NextCell2:
    Next 'cell

    Application.ScreenUpdating = True
    MsgBox "処理が完了しました！ 🚀", vbInformation

End Sub

変更点とポイント:

  • Collection を使用: sheetNamesToChange という Collection オブジェクトを使って、追加したシートオブジェクトと、それに付けたい新しいシート名をペアで格納します。
  • 後で名前を変更: シートを追加した時点では、仮の名前（またはそのまま）にしておき、ループが終わった後にコレクションを使って一括で名前を変更します。
  • シート名の重複チェック: On Error Resume Next を使って、指定したシート名が既に存在するかどうかをチェックし、重複する場合はスキップするようにしました。

どちらのコードが良いか？

今回のケースでは、月の数字（4, 5, ..., 12, 1, 2, 3）は重複しないので、test_Revised1 の方がシンプルで分かりやすいと思います。

コードを試す前に

  1. バックアップ: 大切なブックで試す前に、必ずバックアップを取ってくださいね！
  2. シート名の確認: 「年月」シートのA列に、期待通りの月を表す数字（例: "20254", "20255"）が入っているか再確認してみてください。
  3. フォルダパス: ThisWorkbook.path で取得されるパスは、ブックA（マクロを実行しているブック）と同じフォルダです。このフォルダに新しいブックが作成されます。

これで、シート名の変更もバッチリできるはずです！もし、また何か疑問点があったり、新しいアイデアが浮かんできたりしたら、いつでも気軽に声をかけてくださいね！一緒に楽しく解決していきましょう！✨

2025/11/25 13:24
AIの回答は正しいとは限りません。また、個人情報などの重要な情報は入力しないでください
0

48 件のコメント

読み込み中...
Your avatar