スキルアップ・問題解決なら、モーグにおまかせ！

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

よく読んでいませんが、
wb.Close (False)で変更を保存せずに閉じているから、と言うことは無いですか？

simpleさん
 
wb.Close にすると保存確認ダイアログが出てしまうのですが
保存にしてもシート名は変更されていません
 
wb.Close (true)
でもシート名が変更できません

str = nengetuCell.Value
str1 = Left(nengetuCell.Value, 4)
sheetName = Mid(str, Len(str1) + 1)

simpleさん
 
strには年月シート
20254
20255
20256
20257
20258
20259
202510
202511
202512
20261
20262
20263
の各セル値が
 
str1には
上記年月シートの
各セル値左から4文字の値
2025
2026
 
sheetNameには
strからstr1除いた
4
5
6
7
8
9
10
11
12
1
2
3
が入ります
 
 
先ほどご指摘いただいた件をきっかけに
 
Application.SheetsInNewWorkbook = 1
 
wb.Close (False)をwb.Close (True)にして
 
ループのところに Activateを入れると
 
               Next nengetuCell
  
            addWs.Activate
                 
             wb.Close (True)
 
変更？追加？できるようになりました
ただ、
望んだ
4,5,6,7,8,9,10,11,12,1,2,3 というシートではなく
 
3,2,1,12,11,10,9,8,7,6,5,4,Sheet1
という結果になってしまっています

wb.close　True
もいいですが、(細かいですがカッコは不要です）
wb.save
wb.close
でもよいでしょう。明示的に保存していることがわかるので。
 
また、

Set addWs = wb.Worksheets.Add(After:=Sheets(Worksheets.Count))

Set addWs = wb.Worksheets.Add(After:=wb.Sheets(wb.Worksheets.Count))

記載のVBAでは
普通に「ブック１.xlsm」が作成され、
Sheet1の横に4〜３のシート12枚が
作成されています。
 
シート名の変更ができないという意味が
よく分かりませんが。
 
ただ、記載のVBAでは、closeの部分以外に
行数が数えられていないので
ブック１しかできないと思います。
 
シートは年月シートのデータが並んでいる通りに
4〜３が作成されましたが？

12行数えるようにして、
他シートにデータがなければ、例えば
lastRow = ws.UsedRange.Cells(ws.Rows.Count, 1).End(xlUp).Row
 
一番左のsheet1が不要であれば、
Worksheets(1).Deleteで
削除すれば良いのかと思います。

↑シートに他のデータが無ければ、
 
すみません。

 紙頼さん
> ただ、記載のVBAでは、closeの部分以外に
> 行数が数えられていないので
> ブック１しかできないと思います。
コードが整理されておらず説明も足らず申し訳ありません
ブックAのシートdb140のAW列にあるセルの値から
同じフォルダ内へそのセルの値が名前となるブックを作成しています
 
  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
            Application.SheetsInNewWorkbook = 1
         
            Set wb = Workbooks.Add
            thisPath = ThisWorkbook.path
            wbName = cell.Value & ".xlsm"
             
            wb.SaveAs fileName:=thisPath & "\" & wbName, FileFormat:=xlOpenXMLWorkbookMacroEnabled
 
〜省略〜
    
Next 'cell

simpleさん、紙頼さん
Set addWs = wb.Worksheets.Add(After:=wb.Worksheets(wb.Worksheets.Count))
としてやることで4〜3でシートが並び
残ったSheet1は
Application.DisplayAlerts = False
wb.Worksheets("Sheet1").Delete
Application.DisplayAlerts = True
で削除
保存するかダイアログが出るので
wb.Close True
とすることで当初解決できなかったシート名の変更とは違う形になりましたが
望む動作とすることが出来ましたのでひとまず解決とさせていただきます
すいません、ありがとうございました