VBA: Excelの複数シートをコピーして 名称をつけ保存

Question

Excel VBAについて教えてください。

3つのExcelシートのうち2シートをコピーして、
残りの １シートに記載された部の数だけファイルを作成（ファイル名は部名称）　
コピーしたそれぞれのファイルの決められたセルには部名称を記載

＜詳細＞
Excelシートは、「一覧」 「1」 「部」　という3シートあり、「一覧」と「1」 という2シートをコピーして ファイル名は 「部」名称で保存。　
部別に作成された　「1」 というシートの C12 セルには部署名を入力

「部」のシートには、下記にように記載されております。

部署　 部署名
QA MQA
QB MQB
QC MQC

下記VBA記載の場合、「1」 というシートのみコピーされ、保存できましたが、「一覧」シートも一緒に コピー保存をしたい為、その方法をご教示ください。

Sub シート作成()
Dim a
For a = 2 To Sheets("部").Range("B30").End(xlUp).Row

Sheets("1").Copy After:=Sheets(Sheets.Count)
Sheets(Sheets.Count).Name = Sheets("部").Range("B" & a).Value

Sheets(Sheets.Count).Range("C12").Value = Sheets("部").Range("C" & a)
Sheets(Sheets.Count).Copy
Application.DisplayAlerts = False
Dim myDate As Variant
myDate = DateSerial(Range("M7"), Range("O7"), 1)

ActiveWorkbook.SaveAs "C:\Users\satoko.h" & ActiveSheet.Name & "" & Format(myDate, "yymm") & " " & "AAAA" & ".xlsx"
ActiveWorkbook.Close
Sheets(Sheets.Count).Delete
Sheets("1").Select

Next
End Sub

ーーーーーーーーーーー
ARRAY で SHEETS(ARRAY("一覧","1")).COPY
として作成しようとしましたが、思ったような結果になりませんでした。

　どうぞよろしくお願いいたします。

Answer 1

今回のようにコピーしたりブックを閉じたりするとアクティブブックがその都度変わります。
Sheets("1") というようにブック名を付けないと、アクティブブックが対象になりますが、このようにアクティブブックが変化するような処理ではコードが読みづらくなりバグの元になります。

このような場合は、ブック名を省略せずに指定するようにしましょう。同じブックが繰り返し出現する場合は変数に代入しておいて、それを指定するといいでしょう。
あるいは、With 構文を利用するのもコードが読みやすくなります。

自分が書くなら下記のような感じにします。

Sub シート作成()
    Dim myWB As Workbook: Set myWB = ThisWorkbook    '自身のワークブック

    With myWB.Sheets("1")
        Dim myDate As String
        myDate = Format(DateSerial(.Range("M7"), .Range("O7"), 1), "yymm")
    End With
    
    Application.DisplayAlerts = False

    Dim a As Long
    For a = 2 To myWB.Sheets("部").Range("B30").End(xlUp).Row

        myWB.Sheets(Array("一覧", "1")).Copy    '2シートを新規ブックにコピー
        With ActiveWorkbook    '新規ブック
            Dim buName As String: buName = myWB.Sheets("部").Range("B" & a).Value
            .Sheets("1").Range("C12").Value = myWB.Sheets("部").Range("C" & a)
            .Sheets("1").Name = buName
            ActiveWorkbook.SaveAs "C:\Users\satoko.h\" & buName & "_" & myDate & "_" & "AAAA" & ".xlsx"
            ActiveWorkbook.Close
        End With
    Next

    Application.DisplayAlerts = True

End Sub

Comments

[SatokoH]

ありがとうございます。With 構文や変数をうまく利用すれば、とても読みやすい構文になりますね。ブック名につきましても とても勉強になりました。

Answer 2

こんな感じでどうでしょうか。

Sub シート作成()
    
    Dim a
    
    Dim b As Worksheet, c As Sheets
    With ThisWorkbook
        Set b = .Worksheets("部")
        Set c = .Worksheets(Array("1", "一覧"))
    End With
    
    Dim buName As String, newBook As Workbook, newSheet As Worksheet
    
    For a = 2 To b.Range("B30").End(xlUp).Row
        
        buName = b.Cells(a, 2).Value
        c.Copy
        Set newBook = ActiveWorkbook
        Set newSheet = newBook.Worksheets("1")
        
        With newSheet
            .Name = buName
            .Range("C12").Value = buName
        End With
        
        With newBook
            .SaveAs buName
            .Close False
        End With
    Next
    
End Sub

Comments

[SatokoH]

ありがとうございます。シンプルでとても読みやすい構文ですね。おかげさまで解決致しました。