Excel VBA 複数シートを別ファイルにコピーして保存

Excel VBAはまだ初心者なので、よくわかっていないのですが、複数シートを別ファイルにコピーして保存したいと思っております。

下記は、一番左のシートだけをB1に書かれ値で別ファイルとして保存できるようなものをつくってみました。ここから、左から1番目と2番目だけをコピーして、同じようにファイル名を指定して保存したいと考えていますが、全くうまくいかず・・・。

お手数ですが、どこを修正すべきなのかをおしえていただけますでしょうか。

よろしくお願いいたします。

Sub SheetSave()

Dim xSheet As Worksheet
Dim myFile As String
Dim myName As String

Set xSheet = ActiveSheet

'一番左のファイルのコピー
ThisWorkbook.Worksheets(1).Copy after:=ThisWorkbook.Worksheets(1)

myFile = ThisWorkbook.Path & "\" & xSheet.Range("B1").Value & ".xlsx"
Application.DisplayAlerts = False
ActiveSheet.SaveAs fileName:=myFile
Application.Dialogs(xlDialogSaveAs).Show
Application.DisplayAlerts = True
ActiveWorkbook.Close

End Sub

No.1 回答者： WindFaller 回答日時： 2017/04/30 23:16

コードの内容と質問とは違うようですね。

>ThisWorkbook.Worksheets(1).Copy after:=ThisWorkbook.Worksheets(1)
これは、シートをCopyして付け足すという意味です。

>ここから、左から1番目と2番目だけをコピーして
ということはシートのことですね。

シートひとつずつを、単独のブックにするということならこうなるはずですが。

本当は、ActiveSheet の部分を決めたほうが良いと思います。
質問と文章から最大限に汲み取れる内容というと、以下のようなものになります。

'//
Sub mySheetSave()
　Dim xSheet As Worksheet
　Dim myFile As Variant
　Dim fName As Variant
　Dim i As Long
　Dim newBook As Workbook
　Set xSheet = ActiveSheet
　fName = xSheet.Range("B1").Value
　
　For i = 1 To 3
　ThisWorkbook.Worksheets(i).Copy
　Set newBook = ActiveWorkbook
　myFile = Application.GetSaveAsFilename(fName, _
　 FileFilter:="Excel File (*.xlsx),*.xlsx,Excel File Macro(*.xlsm),*.xlsm")
　If VarType(myFile) = vbBoolean Then Exit Sub
　newBook.SaveAs myFile, xlWorkbookNormal
　newBook.Close False
　Next i
End Sub

この回答へのお礼

ご連絡が遅くなってしまい申し訳ございませんでした。

＞シートひとつずつを、単独のブックにするということならこうなるはずですが。

やろうとしていた処理は、1つのブックの2シートを1つのブックにコピーするといったものでした。
こちらの説明が曖昧ですみません。回答頂いたもう一人の方の回答で解決できました。

また、シート一つずつを単独ブックにするやり方については大変参考になりました。
このような処理が必要になったときに活用させていただきます。とても勉強になりました。

ありがとうございました。

お礼日時：2017/05/06 14:16

No.2 ベストアンサー 回答者： bonaron 回答日時： 2017/05/02 05:38

シート２枚まとめて１つのブックにコピーということなら

Sub SheetSave2()
　　Const N As Long = 2
　　Dim myFile As String
　　Dim myName As String
　　Dim mySh(1 To N) As String
　　Dim i As Integer

　　myFile = ThisWorkbook.Path & "\" & ActiveSheet.Range("B1").Value & ".xlsx"

　　'左から N番目までのシートをコピー
　　For i = 1 To N
　　　　mySh(i) = Sheets(i).Name
　　Next
　　Sheets(mySh).Copy

　　Application.DisplayAlerts = False
　　ActiveWorkbook.SaveAs Filename:=myFile
　　Application.DisplayAlerts = True
　　ActiveWorkbook.Close
End Sub

この回答へのお礼

ご連絡が遅くなりまして、申し訳ございませんでした。
まさにこれがやりたかった処理です。
本当にありがとうございました。
まだまだ初心者なのでわからないことばかりですが、今回の回答を参考に勉強させていただきます。

お礼日時：2017/05/06 14:04