ＶＢＡ 各シートごとに別々に保存

いつもお世話になっております。
下記のコードは
各シートをそれぞれ別のに
保存するコードを検索して見つけましたが
エラーになります。
一度上手くいきましたがそれ以降
上手くいきません。
わかる方おしえてくれませんでしょうか

DDのシートはダミーです。
Sheet1
Sheet2
Sheet3
があります。


Sub sheets_save()

For Each shs In Worksheets
If shs.Name <> "DD" Then
shs.Copy

ActiveWorkbook.SaveAs ThisWorkbook.Path & " \" & shs.Name
ActiveWorkbook.Close

End If
Next shs
End Sub

No.5 ベストアンサー 回答者： Qchan1962 回答日時： 2021/04/21 22:35

＃３＃４です

ちゃんと確認せずに、いい加減な回答をしてしまいました。
shs.Name = shs.Name & "(" & n & ")"
シート名を変更してしまいました。。。これはまずいです。

大変申し訳ありませんが、訂正したものを投稿します
Sub sheets_save()
Dim shs As Worksheet, n As Integer
Dim BN As String
For Each shs In Worksheets
If shs.Name <> "DD" Then
shs.Copy
If Dir(ThisWorkbook.Path & "\" & shs.Name & ".xlsx") <> "" Then
' MsgBox "同名のブックが存在するので枝番を付加します"
plsNumber:
n = n + 1
BN = "(" & n & ")"
If Dir(ThisWorkbook.Path & "\" & shs.Name & BN & ".xlsx") <> "" Then GoTo plsNumber
End If
n = 0
ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & shs.Name & BN
ActiveWorkbook.Close
End If
BN = ""
Next shs
End Sub

この回答へのお礼

いつもお世話になっております。
うまくいきました。
plsNumber:
n = n + 1
BN = "(" & n & ")"　初めてみます。調べてみます。
ありがとうございました。

お礼日時：2021/04/21 22:50

No.6 回答者： fujillin 回答日時： 2021/04/21 22:40

こんばんは

No2様に一票！

＞一度上手くいきましたがそれ以降上手くいきません。
同じ名前で保存しようとして、エラーが出ているだけではないでしょうか？

この回答へのお礼

いつもお世話になっております。
恐らくそうだと思います。
ありがとうございました。

お礼日時：2021/04/21 22:50

No.4 回答者： Qchan1962 回答日時： 2021/04/21 22:19

間違え

If Dir(ThisWorkbook.Path & "\" & shs.Name) <> "" Then GoTo plsNumber
訂正
If Dir(ThisWorkbook.Path & "\" & shs.Name & ".xlsx") <> "" Then GoTo plsNum

No.3 回答者： Qchan1962 回答日時： 2021/04/21 22:16

こんばんは、

上手くいかないとは、同名ファイルがあるからと言う事でしょうか？
もしそうであるなら、ファイルの存在を確認して処理を分ける方法を考えてみては、
参考
Sub sheets_save()
Dim shs As Worksheet, n As Integer
For Each shs In Worksheets
If shs.Name <> "DD" Then
shs.Copy
If Dir(ThisWorkbook.Path & "\" & shs.Name & ".xlsx") <> "" Then
MsgBox "同名のブックが存在するので枝番を付加します"
plsNumber:
n = n + 1
shs.Name = shs.Name & "(" & n & ")"
If Dir(ThisWorkbook.Path & "\" & shs.Name) <> "" Then GoTo plsNumber
End If
n = 0
ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & shs.Name
ActiveWorkbook.Close
End If
Next shs
End Sub

それと、￥の前の半角スペース　タイプミスですよね？

この回答へのお礼

いつもお世話になっております。
それと、￥の前の半角スペース　タイプミスですよね？
そうでした。

お礼日時：2021/04/21 22:37

No.2 回答者： めぐみん_ 回答日時： 2021/04/21 21:59

＞一度上手くいきましたがそれ以降上手くいきません。

だって既にその名前のＢｏｏｋが存在するからでは？
以前のＢｏｏｋをどうしたいのか？によって処理が変わると思いますよ。
エクスプローラーでＢｏｏｋファイルをカーソルで囲って削除してからやるとかも手ではあります。

この回答へのお礼

いつもお世話になっております。
確認します。
ありがとうございます。

お礼日時：2021/04/21 22:35

No.1 回答者： ぽち101 回答日時： 2021/04/21 21:56

円マークの前に半角スペースが入ってしまっているからではないでしょうか？

誤：" \"
正："\"

この回答へのお礼

ありがとうございます。

お礼日時：2021/04/21 22:35