シート毎に別々のファイルに保存する

Question

シート毎に別々のファイルに保存するためのVBAを作成しております。
現在のコードは以下の通りです。

'シート名をそのままファイル名にする方法

Dim i As Integer
Dim wb1 As Workbook
Dim SheetCnt As Integer
 
Set wb1 = ActiveWorkbook
SheetCnt = wb1.Sheets.Count
 
For i = 1 To SheetCnt
If Sheets(i).Visible = True Then
ChDir CreateObject("WScript.Shell").SpecialFolders("desktop") & "\"
Workbooks.Add.SaveAs Filename:="分析_" & Worksheets(i).Name & ".xlsx"
wb1.Worksheets(i).Copy Before:=Workbooks("分析_" & Worksheets(i).Name & ".xlsx").Worksheets(1)　　・・・①
'シートを保存して閉じる
ActiveWorkbook.Close SaveChanges:=True
End If

マクロを実行すると新しいworkbook作成迄は実行されますが、その後のコピペ（①の箇所）でエラーとなります。
どの様に変更すれば良いか教えて頂けないでしょうか。
併せて「シートを保存して閉じる」際に「リンクの自動更新を無効」にしたまま保存する様にしたいと考えています。

良いお知恵をお貸しください。
宜しくお願いします。

fujillin · Accepted Answer

こんにちは

少し整理してみました。

＞「リンクの自動更新を無効」にしたまま
もとのブックにリンクが存在するということでしょうか？
個々に処理をするのが面倒だったので、まとめて「値をペースト」形式にしてしまっています。
（ですので、シート内リンクや関数式も値に変換されちゃいます）

きちんと「リンクの自動更新を無効」をなさりたい場合は、BreakLinkで処理してください。
https://docs.microsoft.com/ja-jp/office/vba/api/excel.workbook.breaklink

※ 既存のファイル名をチェックしていませんので、同名のファイルが存在する場合には上書きの確認メッセージが表示されます。
※ シート数が多く画面がチラつくような場合は、ScreenUpdatingをFalseにするとよいでしょう。

Sub Sample_11700270()
Dim sPath As String, sh As Worksheet
sPath = CreateObject("WScript.Shell").SpecialFolders("desktop") & "\分析_"

For Each sh In Worksheets
　sh.Copy
　ActiveSheet.UsedRange.Value = ActiveSheet.UsedRange.Value
　ActiveWorkbook.SaveAs Filename:=sPath & sh.Name & ".xlsx"
　ActiveWorkbook.Close SaveChanges:=False
Next sh
End Sub

Qchan1962 · Answer

＃３です。
＃１の補足を見て
一応、不具合を避けるため、wb1.　を　あと2か所（全部で3か所）追記しブックを明示した方が良いと思います。
更に、デバックなどで再度実行時エラーを避けるために
    Else
        fso.CreateFolder (FolPath)
    End If
    Set fso = Nothing　　'破棄しておいた方が良いと思います。

あと、ChDir FolPath　で良いと思いますよ。同じなので、、

Qchan1962 · Answer

こんばんは、
横から失礼します。リンクについては、すでに回答が出ておりますので、
エラー箇所へのアドバイスです。
SheetCnt = wb1.Sheets.Count　コピー元のシート数
For i = 1 To SheetCnt　コピー元のシート数分ループする

wb1.Worksheets(i).Copy Before:=Workbooks("分析_" & Worksheets(i).Name & ".xlsx").Worksheets(1)

1周目のForでは、i＝1なので必ずありますが、2周目では、あるかどうかは、わかりません。
Excelのオプションで新規作成ブックのシート数が影響します。

この場合、Workbooks("分析_" & Worksheets(i).Name & ".xlsx")のシートを作成して行く方法か、コピーシートを
挿入して行く方法を取らないと　2周目　Worksheets(i).Namは、インデックス2となり、Workbooks.Addで作成したブックになければ
当然、エラーが返りますね。
しかし、シートを作って行きたい訳ではないでしょうから、、
多分、
Worksheets(i).Nameが元ブックのシート名を指すものと推測します。従って、
Workbooks("分析_" & wb1.Worksheets(i).Name & ".xlsx")　とするようにします。

検証していませんので的違いなら、忘れてください。

fujillin · Answer

No1です

＞先ほどご教授頂いたコードでは上手くいかなくて....
何がうまくいかないのかが不明ですが、No1のコードではデスクトップ上に「分析_ & シート名」のファイル名で各シートが保存されるはずです。
そうなってはいないでしょうか？
（ご提示のコードの内容が、そのように読み取れましたので）

デスクトップ上の「あ」フォルダに保存したければ、
sPath = CreateObject("WScript.Shell").SpecialFolders("desktop") & "\分析_"
を
sPath = CreateObject("WScript.Shell").SpecialFolders("desktop") & "\あ\い_"
に変えればすむだけのことと思いますけれど・・・？

※ No1にも記しましたように、フォルダの存在チェックや作成、ファイルの既存在チェックなどは行っていませんので必要に応じて追加してください。

シート毎に別々のファイルに保存する

こんにちは

＃３です。

こんばんは、

No1です

似たような質問が見つかりました

関連するカテゴリからQ&Aを探す

デイリーランキングこのカテゴリの人気デイリーQ&Aランキング

マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング