決められたセル範囲のみ別ファイルに保存するマクロ

質問

Book内のシートSheet1,Sheet2,Sheet3を別個のCSVファイルSheet1.csv／Sheet2.csv／Sheet3.csvとして保存したいです。
過去ログを参考に以下のコードで正常に動作しました。
For Num = 1 To 3
SheetName = "Sheet" & Num
Worksheets(SheetName).Copy
ActiveSheet.SaveAs Filename:=myPath & SheetName, FileFormat:=xlCSV, CreateBackup:=False
ActiveWorkbook.Close False
Next

ここで、
決められたセル範囲A1:D5に書かれたデータのみをCSVファイルとして保存する、
といったことをしたいのですが、記述の仕方を教えてください。
その範囲以外が削除されてしまっても構わないので、
その範囲以外をクリアしてから保存を実行、というコードも組んだのですが、
上書き保存されているシートに対して行うとクリアする前の状態のシートをコピーするようで、失敗しました。

Worksheets(SheetName).Copyの部分を、
Sheets(SheetName).Select
Range("A1:D5").Copy
と変えてみたのですが、マクロを実行したファイルが閉じてしまい、巧く動きません。
※myPathには保存先フォルダのパスが入ります。

また、保存の際に「同名のファイルがあるが、上書きするか？」のメッセージを出さずに強制的に上書きにする方法はありますか？

回答No.2

Wendy02 · ベストアンサー

こんにちは。

以前の私のコードの書き方に、良く似ていますね。特に、.Close False は、私の独特の考えで書いているからです。

ただ、私のオリジナルは、こういう書き方ではなくて、直接、CSVを作ってしまうのですが、あくまでも、掲示板で公開するためのものです。

>保存の際に「同名のファイルがあるが、上書きするか？」
は、Application.DisplayAlart =False
です。

今回は、二種類作ってみました。
TestSample1
>その範囲以外が削除されてしまっても構わないので、
>その範囲以外をクリアしてから保存を実行、というコード

TestSample2

その範囲以外が削除されてしまっては、困る場合
シート名のファイルがない場合は、その範囲のみCSVにします。

------------------------------------------------------
Sub TestSample1()
　　'規定の範囲のみを残す
　　Dim Num As Integer
　　Dim myPath As String
　　Dim SheetName As String
　　Dim r As Range

　　Const MYRNG As String = "A1:D5" '規定の範囲のみを残す
　　'　="" とすれば、シート全体がコピーされる
　　'ユーザー任意
　　myPath = Application.DefaultFilePath & "\"

　　Application.ScreenUpdating = False
　　For Num = 1 To 3
　　　　SheetName = "Sheet" & Num
　　　　If MYRNG <> "" Then
　　　　　　Set r = Worksheets(SheetName).Range(MYRNG)
　　　　End If
　　　　Worksheets(SheetName).Copy
　　　　With ActiveSheet
　　　　　　If MYRNG <> "" Then
　　　　　　　　.UsedRange.Clear 'シートのデータを削除
　　　　　　　　r.Copy .Range("A1") 'データのコピー&ペースト
　　　　　　End If
　　　　　　Application.DisplayAlerts = False
　　　　　　.SaveAs FileName:=myPath & SheetName, _
　　　　　　FileFormat:=xlCSV, _
　　　　　　CreateBackup:=False
　　　　　　Application.DisplayAlerts = True
　　　　End With
　　　　ActiveWorkbook.Close False
　　Next
　　Application.ScreenUpdating = True
End Sub

------------------------------------------------------
Sub TestSample2()
'規定の範囲のみを書き換える
　　Dim Num As Integer
　　Dim myPath As String
　　Dim SheetName As String
　　Dim FileName As String
　　Dim r As Range

　　Const MYRNG As String = "A1:D5" '規定の範囲のみを書き換える
　　'ユーザー任意
　　myPath = Application.DefaultFilePath & "\"

　　Application.ScreenUpdating = False
　　For Num = 1 To 3
　　　　SheetName = "Sheet" & Num
　　　　Set r = Worksheets(SheetName).Range(MYRNG)

　　　　FileName = myPath & SheetName & ".csv"

　　　　If Dir(FileName) <> "" Then

　　　　　With Workbooks.Open(FileName)
　　　　　　r.Copy .ActiveSheet.Range(MYRNG)
　　　　　End With

　　　　Else

　　　　Worksheets(SheetName).Copy
　　　　With ActiveSheet
　　　　　　.UsedRange.Clear
　　　　　　r.Copy .Range("A1")
　　　　End With
　　　　End If

　　 Application.DisplayAlerts = False
　　　 ActiveWorkbook.SaveAs FileName:=myPath & SheetName, _
　　　　　　FileFormat:=xlCSV, _
　　　　　　CreateBackup:=False
　　 Application.DisplayAlerts = True
　　　　ActiveWorkbook.Close False
　　Next
　　Application.ScreenUpdating = True
End Sub

お礼

回答ありがとうございます。

わざわざ２つもありがとうございます。
後者が理想だったのでこちらを組み込んでいる最中です。
(自分にとっては)コードが長くなってきて混乱し始めました。
変数rに入っている情報はデバッグ時にカーソルを合わせても表示されないようですが、
ここにコピー範囲などが入っているものとして扱っています。

>以前の私のコードの書き方に、良く似ていますね。
過去ログを参考に、と書きましたが、
コードは載っていたもののほぼパクりなので、Wendy02さんの書いた記事だったかもしれません。

回答No.3

zap35

＃０１です。「コピーしたシートを消す」と「元のブック名を変えない」ようにしました。また同名ファイルがある場合は警告なしで上書きします

For Num = 1 To 3
SheetName = "Sheet" & Num
Worksheets(SheetName).Range("A1:D5").Copy
WorkSheets.Add
ActiveSheet.Paste
Application.DisplayAlerts = False
ActiveSheet.SaveCopyAs Filename:=myPath & SheetName, _
　　FileFormat:=xlCSV, CreateBackup:=False
ActiveSheet.Delete
Application.DisplayAlerts = True
Next

お礼

回答ありがとうございます。

注文つけちゃって申し訳ありません。
挙げていただいたコード、１行ずつ解析します。

回答No.1

zap35

For Num = 1 To 3
SheetName = "Sheet" & Num
Worksheets(SheetName).Range("A1:D5").Copy
WorkSheets.Add
ActiveSheet.Paste
ActiveSheet.SaveAs Filename:=myPath & SheetName, _
　　FileFormat:=xlCSV, CreateBackup:=False
Next
ActiveWorkbook.Close False

ではどうでしょうか。「マクロを実行したファイルが閉じてしまい」はFor～Nextの中でCloseしているからです

「同名のファイルがあるが、上書きするか？」のメッセージを出さない方法として
　Application.DisplayAlerts = False
　ThisWorkBook.SaveAs　…
　Application.DisplayAlerts = True
があります。

補足

回答ありがとうございます。

求めていた部分は正常に動作しました。
ただ、
・実行後、Book内にSheet4～6というシートが残ってしまう
・実行後、Book名がSheet3.csvになってしまう
という新たな問題が発生してしまいました。
最初に挙げたコードでFor～Nextの中でCloseしているのは、
CSVファイルの保存に使ったシートSheet4～6を閉じるつもりで配置したものです。
・Book内にシートを増やさない
・マクロ実行後、マクロを実行したBookを開いている状態に
この２点、なんとかなるようでしたらよろしくお願いします。