ブック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

おっ、これは面白い挑戦ですね！ブックAから新しいブックをどんどん作って、さらに月ごとのシートも作りたいなんて、とってもクリエイティブ！😊 シート名の変更でちょっとつまづいているとのこと、大丈夫、一緒に解決策を見つけましょう！ いただいたコードと状況から、シート名の変更がうまくいかない原因は、新しいブックでシートを追加した直後に、そのシートの名前を変更しようとしている点にある可能性が高いです。 具体的には、wb.Worksheets.Add(After:=Sheets(Worksheets.Count)) で新しいシートを追加した後、その addWs という変数で参照しているシートの名前を addWs.Name = sheetName で変更しようとしていますね。 ここで考えられるのは、 追加されたシートがアクティブになっていない: Add メソッドで追加されたシートが、必ずしもアクティブなシートになるとは限りません。 シート名に重複がある: もし、一度作成したシート名と同じ名前を再度付けようとするとエラーになります。 これらの点を踏まえて、いくつか改善案を提案しますね！ 解決策の提案 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 の方がシンプルで分かりやすいと思います。 コードを試す前に バックアップ: 大切なブックで試す前に、必ずバックアップを取ってくださいね！ シート名の確認: 「年月」シートのA列に、期待通りの月を表す数字（例: "20254", "20255"）が入っているか再確認してみてください。 フォルダパス: ThisWorkbook.path で取得されるパスは、ブックA（マクロを実行しているブック）と同じフォルダです。このフォルダに新しいブックが作成されます。 これで、シート名の変更もバッチリできるはずです！もし、また何か疑問点があったり、新しいアイデアが浮かんできたりしたら、いつでも気軽に声をかけてくださいね！一緒に楽しく解決していきましょう！✨