saveas メソッドは失敗しました workbookオブジェクト

前提・実現したいこと

はじめまして、エラーの避け方について教えてください

現在リストのIDごとに別ブックを作るVBAを作成しています。
IDがひとつの場合はうまくいきますが、２つ以上だと同じ場所でエラーが出てしまいます。

調べたところいくつか解決法がありましたが、どれもうまくいきません。

発生している問題・エラーメッセージ

saveas メソッドは失敗しました workbookオブジェクト

該当のソースコード

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 R_Data As Integer    'データの行番号
Dim Ko As Integer    'グループの件数

    
Set MacroB = Workbooks("作成マクロ.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")


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) & "_" & Cells(2, 2) & ".xlsx", FileFormat:=1__
↑ここで『saveas メソッドは失敗しました workbookオブジェクト』がでます

    '指定したフォルダーに保存
    Wb_new.Close
            
    R_Data = R_Data + Ko
            
Loop While Cells(R_Data, C_Group) <> ""

MsgBox "完了！"
            
Application.ScreenUpdating = True

End Sub

試したこと

・, FileFormat:=1 の追加、削除を行いましたが
どうしても重複が複数あるときに同じことが起こります。

・エクセルの再起動
・変数宣言を強制するにチェック

imihito

2019/02/19 12:51

修正依頼：コードの前後に「```」を追加し、コードを見やすくしてください（コードを選択して<code>ボタンでも可） / 情報追記依頼：① SaveAs実行時に`Path & Cells(2, C_Group) & "_" & Cells(2, 2) & ".xlsx"`がどんな値になっているか。② 表の大まかな構成について。

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

回答1件

色々あるかと思いますが、重複を避けてナンバリングする方法はいかがでしょうか。
動かしてないのでエラーがあるかも（＾＾；
重複したときは保存したくなければ保存しなければOKです。
あと、重複したくないだけだったらファイル名に日時を入れるのも手です。保存時間（秒）がずれるはずなので。

VBA
1       Dim strFileName As String
2       Dim lngFIleNo As Long
3       lngFIleNo = 1
4       strFileName = Path & Cells(2, C_Group) & "_" & Cells(2, 2)
5       Do While True   '保存するまで繰り返す
6           If Dir(strFileName & lngFIleNo & ".xlsx") = "" Then 'ファイルが既に存在しているか調べる
7               '無いのでそのまま保存
8               Wb_new.SaveAs Filename:=strFileName & lngFIleNo & ".xlsx", FileFormat:=1
9               Exit Do
10           Else
11               'あるので名前を変える
12               lngFIleNo = lngFIleNo + 1
13               '飛ばす場合は Exit Do
14           End If
15       Loop
16