質問をすることでしか得られない、回答やアドバイスがある。

15分調べてもわからないことは、質問しよう!

ただいまの
回答率

88.36%

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

受付中

回答 1

投稿

  • 評価
  • クリップ 1
  • VIEW 11K+

yumeno

score 19

前提・実現したいこと

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

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

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

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

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 の追加、削除を行いましたが
どうしても重複が複数あるときに同じことが起こります。

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

  • 気になる質問をクリップする

    クリップした質問は、後からいつでもマイページで確認できます。

    またクリップした質問に回答があった際、通知やメールを受け取ることができます。

    クリップを取り消します

  • 良い質問の評価を上げる

    以下のような質問は評価を上げましょう

    • 質問内容が明確
    • 自分も答えを知りたい
    • 質問者以外のユーザにも役立つ

    評価が高い質問は、TOPページの「注目」タブのフィードに表示されやすくなります。

    質問の評価を上げたことを取り消します

  • 評価を下げられる数の上限に達しました

    評価を下げることができません

    • 1日5回まで評価を下げられます
    • 1日に1ユーザに対して2回まで評価を下げられます

    質問の評価を下げる

    teratailでは下記のような質問を「具体的に困っていることがない質問」、「サイトポリシーに違反する質問」と定義し、推奨していません。

    • プログラミングに関係のない質問
    • やってほしいことだけを記載した丸投げの質問
    • 問題・課題が含まれていない質問
    • 意図的に内容が抹消された質問
    • 過去に投稿した質問と同じ内容の質問
    • 広告と受け取られるような投稿

    評価が下がると、TOPページの「アクティブ」「注目」タブのフィードに表示されにくくなります。

    質問の評価を下げたことを取り消します

    この機能は開放されていません

    評価を下げる条件を満たしてません

    評価を下げる理由を選択してください

    詳細な説明はこちら

    上記に当てはまらず、質問内容が明確になっていない質問には「情報の追加・修正依頼」機能からコメントをしてください。

    質問の評価を下げる機能の利用条件

    この機能を利用するためには、以下の事項を行う必要があります。

質問への追記・修正、ベストアンサー選択の依頼

  • imihito

    2019/02/19 21:51

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

    キャンセル

回答 1

0

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

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

投稿

  • 回答の評価を上げる

    以下のような回答は評価を上げましょう

    • 正しい回答
    • わかりやすい回答
    • ためになる回答

    評価が高い回答ほどページの上位に表示されます。

  • 回答の評価を下げる

    下記のような回答は推奨されていません。

    • 間違っている回答
    • 質問の回答になっていない投稿
    • スパムや攻撃的な表現を用いた投稿

    評価を下げる際はその理由を明確に伝え、適切な回答に修正してもらいましょう。

15分調べてもわからないことは、teratailで質問しよう!

  • ただいまの回答率 88.36%
  • 質問をまとめることで、思考を整理して素早く解決
  • テンプレート機能で、簡単に質問をまとめられる

関連した質問

同じタグがついた質問を見る