別ブックに保存の際、作業シートと別のシートも保存する方法を知りたい

VBA初心者です。

下記を使ってグループ化されたデータを別ブックに分割。
分割まではできているのですが、分割元ブックに他シートが2つあり、こちらの2つも分割後の新規ブックにコピーしたいのですが、どういったコードになるか教えてください。

お手数お掛け致しますが宜しくお願い致します。

Sub Sample()

　　Dim MacroB As Worksheet　　'このブックのシート
Dim Wb_Data As Workbook　　'1. 分割元ブック
Dim Wb_new As Workbook　　'分割データ保存ブック
Dim Ws As String　　'2. 分割元シート名
Dim Path As String　　'3. 分割データ保存先
Dim C_Group As String　　'4. グループ対象列
Dim C_Copy As String　　'5. コピーデータ右端列
Dim YMD As String　　'6. 保存ブック日付の表示形式
Dim PSW As String　　'7. 読み取りパスワード
Dim R_Data As Integer　　'データの行番号
Dim Ko As Integer　　'グループの件数

　　Set MacroB = Workbooks("ex100010.xlsm").Worksheets(1)　　'このブックのシート
Set Wb_Data = Workbooks(MacroB.Range("C11").Value)　　'分割元のブック名
Ws = MacroB.Range("C12")
Path = MacroB.Range("C13") & "¥"
C_Group = MacroB.Range("C14")
C_Copy = MacroB.Range("C15")
YMD = MacroB.Range("C16")
PSW = MacroB.Range("C17")

　　If YMD = "" Then
YMD = ""
Else
YMD = Format(Date, YMD)
End If

　　R_Data = 2 'データの開始行

　　Application.ScreenUpdating = False

　　Do
Wb_Data.Activate
Worksheets(Ws).Range(Cells(1, 1), Cells(1, C_Copy)).Copy　　'1行目の項目名コピー
Workbooks.Add
ActiveSheet.Paste Range("A1")　　'新規ブックに貼り付け
Set Wb_new = ActiveWorkbook

　　　　Wb_Data.Activate
Ko = WorksheetFunction.CountIf(Columns(C_Group), Cells(R_Data, C_Group)) 'グループの件数を算出
Range(Cells(R_Data, "A"), Cells(R_Data + Ko - 1, C_Copy)).Copy　　'グループ件数分コピー
Wb_new.Activate
ActiveSheet.Paste Range("A2")　　'新規ブック項目の下に貼り付け
Wb_new.SaveAs Filename:=Path & Cells(2, C_Group) & YMD & ".xlsx", _
Password:=PSW　　'指定したフォルダーに保存
Wb_new.Close

　　　　R_Data = R_Data + Ko

　　　　Loop While Cells(R_Data, C_Group) <> ""
MsgBox "完了！"

　　Application.ScreenUpdating = True

End Sub

行動規範の内容に同意します

回答1件

ベストアンサー

＞分割元ブックに他シートが2つあり、こちらの2つも分割後の新規ブックにコピーしたいのですが、どういったコードになるか教えてください。
２シートを丸ごとコピーします。
以下のようになります。追加した行は、'追加・・・のコメントを入れてます。

VBA
1Sub Sample()
2
3    Dim MacroB As Worksheet    'このブックのシート
4    Dim Wb_Data As Workbook    '1. 分割元ブック
5    Dim Wb_new As Workbook    '分割データ保存ブック
6    Dim Ws As String    '2. 分割元シート名
7    Dim Path As String    '3. 分割データ保存先
8    Dim C_Group As String    '4. グループ対象列
9    Dim C_Copy As String    '5. コピーデータ右端列
10    Dim YMD As String    '6. 保存ブック日付の表示形式
11    Dim PSW As String    '7. 読み取りパスワード
12    Dim R_Data As Integer    'データの行番号
13    Dim Ko As Integer    'グループの件数
14
15    Set MacroB = Workbooks("ex100010.xlsm").Worksheets(1)    'このブックのシート
16    Set Wb_Data = Workbooks(MacroB.Range("C11").Value)    '分割元のブック名
17    Ws = MacroB.Range("C12")
18    Path = MacroB.Range("C13") & "\"
19    C_Group = MacroB.Range("C14")
20    C_Copy = MacroB.Range("C15")
21    YMD = MacroB.Range("C16")
22    PSW = MacroB.Range("C17")
23
24    If YMD = "" Then
25        YMD = ""
26    Else
27        YMD = Format(Date, YMD)
28    End If
29
30    R_Data = 2    'データの開始行
31
32    Application.ScreenUpdating = False
33
34    Do
35        Wb_Data.Activate
36        Worksheets(Ws).Activate                                     '追加①
37        Worksheets(Ws).Range(Cells(1, 1), Cells(1, C_Copy)).Copy    '1行目の項目名コピー
38        Workbooks.Add
39        ActiveSheet.Paste Range("A1")    '新規ブックに貼り付け
40        Set Wb_new = ActiveWorkbook
41
42        Wb_Data.Activate
43        Ko = WorksheetFunction.CountIf(Columns(C_Group), Cells(R_Data, C_Group))    'グループの件数を算出
44        Range(Cells(R_Data, "A"), Cells(R_Data + Ko - 1, C_Copy)).Copy    'グループ件数分コピー
45        Wb_new.Activate
46        ActiveSheet.Paste Range("A2")    '新規ブック項目の下に貼り付け
47        Wb_Data.Worksheets(2).Copy after:=Wb_new.Worksheets(1)          '追加②
48        Wb_Data.Worksheets(3).Copy after:=Wb_new.Worksheets(2)          '追加③
49        Wb_new.Activate                                                 '追加④
50        Wb_new.Worksheets(1).Activate                                   '追加⑤
51        Wb_new.SaveAs Filename:=Path & Cells(2, C_Group) & YMD & ".xlsx", _
52                      Password:=PSW    '指定したフォルダーに保存
53        Wb_new.Close
54
55        R_Data = R_Data + Ko
56
57    Loop While Cells(R_Data, C_Group) <> ""
58    MsgBox "完了！"
59
60    Application.ScreenUpdating = True
61
62End Sub
63
64
65