エクセル シートのみ 保存

質問

過去の質問も参照しましたが
当てはまる物が無くて質問しました！
シート上にボタンを作成して
クリックするとそのシートのみ
指定するファイルにコピーさせたいです！
下記の部分で何処を変化させればよいのでしょうか？
(1)～(2)の部分で困っています。

Private Sub CommandButton1_Click()
Dim FileName As String
Dim FileExt As String

’(1)の質問！○＝の部分をSheets（セルのA1の値をファイル名に入れたいです）

FileName = "○"& Format(Now, "yyyy-mm") & ".XLS"

'====
FileName = InputBox(FileName & "と言う名前で保存します" & vbCr & "よろしければこのままOKをクリックしてください", "保存ファイル名の確認", FileName)
If FileName = "" Then
Exit Sub
Else
If Right(FileName, 4) <> ".XLS" Then
MsgBox "ファイル名が異常です。"
Exit Sub
End If
End If
'====

FileName = "D:\保存\ケア\計画\" & FileName

If Dir(FileName) <> "" Then
'##ファイルが既に存在する
If MsgBox("既に指定のファイルが存在します。 上書きしますか?", vbOKCancel, "上書きの確認") = vbCancel Then
'##保存せずに終了
Exit Sub
ElseIf ThisSheets.FullName = FileName Then
'##現在開いているファイルと同じなら上書き保存
ThisSheets.Save
Else
'##指定ファイルを削除した後保存
Kill FileName
ThisSheets.SaveCopyAs FileName:=FileName
End If
Else
'##ファイルを新規保存
ThisSheets.SaveCopyAs FileName:=FileName
End If

ThisSheets.Saved = True
End Sub

(2)ThisSheets＆指定してもう一つだけ
　保存先にコピーしたいです！つまり
　２つのSheetのみ保存させたいのですが・・
　ここからどのようにしたら良いのか
　お願いします！教えて下さい。

回答No.8

pkh4989 · ベストアンサー

ANo.3 です。
ごめんなさい。
以下のように修正してみてください。

　　For wIx = 1 To NewWkbook.Sheets(1).Shapes.Count
　　　　NewWkbook.Sheets(1).Shapes(1).Delete　　　　　'wIx → 1 に修正
　　Next

お礼

本当にありがとうございました！
おかげで完成しました。
また、何度も質問してしまい
本当に申し訳ございません。
ありがとうございました。

回答No.7

pkh4989

こんにちは。
ANo.3 です。
以下のように変更してみてください。

Private Sub CommandButton1_Click()
　　Dim FileName　　As String
　　Dim FileExt　　 As String
　　Dim BkName　　　As String
　　Dim OldWkbook　 As Workbook
　　Dim NewWkbook　 As Workbook
　　Const StName1　 As String = "ko"
　　Const StName2　 As String = "ti"
　　'
　　Application.DisplayAlerts = False
　　Set OldWkbook = ActiveWorkbook
　　'
　　'ファイル名を取得
　　BkName = OldWkbook.Sheets(StName1).Range("A1").Value
　　FileName = BkName & Format(Now, "yyyy-mm") & ".XLS"
　　'
　　FileName = InputBox(FileName & "と言う名前で保存します" & vbCr & "よろしければこのままOKをクリックしてください", "保存ファイル名の確認", FileName)
　　If FileName = "" Then
　　　　Exit Sub
　　Else
　　　　If Right(FileName, 4) <> ".XLS" Then
　　　　　　MsgBox "ファイル名が異常です。"
　　　　　　Exit Sub
　　　　End If
　　End If
　　'
　　OldWkbook.Sheets(Array(StName1, StName2)).Copy
　　Set NewWkbook = ActiveWorkbook
　　For wIx = 1 To NewWkbook.Sheets(1).Shapes.Count
　　　　NewWkbook.Sheets(1).Shapes(wIx).Delete　　　　　'←シート1のボタンを削除
　　Next
　　NewWkbook.Sheets(1).Name = StName1
　　NewWkbook.Sheets(2).Name = StName2
　　'
　　FileName = "D:\保存\ケア\計画\" & FileName
　　'
　　If Dir(FileName) <> "" Then
　　　　'##ファイルが既に存在する
　　　　If MsgBox("既に指定のファイルが存在します。 置き換えますか?", vbOKCancel, "置き換えの確認") = vbCancel Then
　　　　　　NewWkbook.Close savechanges:=False
　　　　　　'##保存せずに終了
　　　　　　Exit Sub
　　　　End If
　　　　'##指定ファイル置き換え保存
　　　　NewWkbook.SaveAs FileName:=FileName
　　Else
　　　　'##ファイルを新規保存
　　　　NewWkbook.SaveAs FileName:=FileName
　　End If
　　'
　　NewWkbook.Close savechanges:=False
　　Application.DisplayAlerts = True
End Sub

補足

本当にありがとうございます！
おかげで上手くいきました！
Sheet上はボタンが２つあり
１つは消えますが
For wIx = 1 To NewWkbook.Sheets(1).Shapes.Count
NewWkbook.Sheets(1).Shapes(wIx).Delete '←シート1のボタンを削除
どの部分を変化させれば良いのでしょうか？

回答No.6

米沢 栄蔵（@YON56）

ANo.5です。
回答は、Moduleに記述して下さい。
Sheetには、
Private Sub CommandButton1_Click()
Call XXX
END Sub
だけです。
Moduleに
Sub XXX()
回答
END Sub
回答をSheetに記述すると、記述内容がSheet以外での行動を指示しているため、エラーになります。

お礼

ありごとうございました！
本当に感謝しています！
何度も質問をしてしまい
ご迷惑おかけしました。

回答No.5

米沢 栄蔵（@YON56）

「特定のファイルの特定のシートを特定の場所に特定の名前を付けたファイルを作りたい。」という質問として、回答します。
○特定の場所に特定の名前を付けたファイルの名前付け。
(シートAAAのセルA1に特定の名前が記述されていると仮定して)
FileName = "D:\保存\ケア\計画\" & Sheets("AAA").Range("A1").Value & Format(Now, "yyyy-mm") & ".XLS"
○特定のファイルの特定のシートをだけの仮ファイルを作る。
(シートAAAとシートBBBとシートCCCだけの仮ファイルを作る仮定して)
Sheets(Array("AAA", "BBB", "CCC")).Copy
この記述だけで、シートAAAとシートBBBとシートCCCだけを含んだBook1という名前の仮ファイルが出来ています。
この方法で仮ファイルを作ると、シートの諸要素全て(マクロや心配されている印刷設定等も含みます。)がコピーされるので、不要になるコマンドボタンを削除する必要があります。
○仮ファイルをFileNameに変更し保存する。
ActiveWorkbook.SaveAs Filename:=FileName
これで、Book1という名前の仮ファイルが、FileNameとして保存されます。

その他の記述は、不要です。Excelが持っている機能で、上書きするかどうかを聞いてくれます。また、FileNameに".XLS"と記述したからにはファイル名の適不適を判断する必要はありません。

お礼

返答ありがとうございました！
本当に勉強になりました！
ありがとうございました。
まとめて記述できるんだ！と思いました。

回答No.4

xls88

そういうことでしたら、まず、「シートの移動またはコピー」作業を「マクロの記録」してください。

≪操作手順≫
(1)シート（"ko")とシート（"ti")をCtrlキーを押しながらクリックして選択
(2)選択したシート見出しの上で右クリック
(3)メニューから「移動またはコピー」をクリック
現れたダイアログボックスで
(4)「コピーを作成する」にチェック
(5)「移動先ブック名」で、「(新しいブック)」を選択
(6)「OK」ボタンをクリック
ここまでで、シート（"ko")とシート（"ti")が新しいブックにコピーされます。
新しいブックがアクティブになっています。そのまま
(7)名前を変えて保存

以上で参考になるコードが得られます。
次に、得られたコードの内容をCommandButton1_Clickマクロに追加編集してみてください。
それで解らないところを質問してください。

≪注意≫
作業終了後、元ブックの、シート（"ko")とシート（"ti")の選択状態を解除しておいてください。
作業グループ状態のままだと、一方のセルデータを書き換えると、他方の同じ番地セルのデータも書き換えられます。

お礼

親切なコメントで
分かりやすく説明していただき
感謝しています！
No3の方の記述で上手くいきました！
ありがとうございました。
出来れば、No3の方にも補足説明
しましたが印刷範囲設定と
ヘッダー・フッターは既存のままに
したいのですが・・・
教えて下さい！

回答No.3

pkh4989

こんにちは。
少し変えて見ました。参考として。。。

Private Sub CommandButton1_Click()
　　Dim FileName　　As String
　　Dim FileExt　　 As String
　　Dim BkName　　　As String
　　Dim OldWkbook　 As Workbook
　　Dim NewWkbook　 As Workbook
　　Const StName1　 As String = "ko"
　　Const StName2　 As String = "ti"
　　'
　　Application.DisplayAlerts = False
　　Set OldWkbook = ActiveWorkbook
　　'
　　'ファイル名を取得
　　BkName = OldWkbook.Sheets(StName1).Range("A1").Value
　　FileName = BkName & Format(Now, "yyyy-mm") & ".XLS"
　　'
　　FileName = InputBox(FileName & "と言う名前で保存します" & vbCr & "よろしければこのままOKをクリックしてください", "保存ファイル名の確認", FileName)
　　If FileName = "" Then
　　　　Exit Sub
　　Else
　　　　If Right(FileName, 4) <> ".XLS" Then
　　　　　　MsgBox "ファイル名が異常です。"
　　　　　　Exit Sub
　　　　End If
　　End If
　　'
　　'新しいブックを生成
　　Workbooks.Add (xlWBATWorksheet)
　　'シートを1枚追加→2枚になる
　　Sheets.Add after:=Worksheets(Worksheets.Count)
　　Set NewWkbook = ActiveWorkbook
　　'シート2枚をコピー
　　OldWkbook.Worksheets(StName1).Cells.Copy Destination:=NewWkbook.Sheets(1).Range("A1")
　　NewWkbook.Sheets(1).Name = StName1
　　OldWkbook.Worksheets(StName2).Cells.Copy Destination:=NewWkbook.Sheets(2).Range("A1")
　　NewWkbook.Sheets(2).Name = StName2
　　'
　　FileName = "D:\保存\ケア\計画\" & FileName
　　'
　　If Dir(FileName) <> "" Then
　　　　'##ファイルが既に存在する
　　　　If MsgBox("既に指定のファイルが存在します。 置き換えますか?", vbOKCancel, "置き換えの確認") = vbCancel Then
　　　　　　NewWkbook.Close savechanges:=False
　　　　　　'##保存せずに終了
　　　　　　Exit Sub
　　　　End If
　　　　'##指定ファイル置き換え保存
　　　　NewWkbook.SaveAs FileName:=FileName
　　Else
　　　　'##ファイルを新規保存
　　　　NewWkbook.SaveAs FileName:=FileName
　　End If
　　'
　　NewWkbook.Close savechanges:=False
　　Application.DisplayAlerts = True
End Sub

補足

ありがとうございました！
早速してみました！上手く出来ました。
本当に感謝しています！
すいませんがもう一つ
教えて下さい！
上手くフォルダにコピーが2つ
入れる事はできましたが
(1)印刷プレビューで印刷範囲設定を
しています！
(2)ヘッダーとフッターも無くなって
いました！
これはNewWBookとしたからなのでしょうか？
お願いします！
Sheet上のボタンはいらないですが
(1)(2)だけはそのままにしたいのですが
教えていただけないでしょうか？

回答No.2

xls88

(2)について

>(2)ThisSheets＆指定してもう一つだけ
>　保存先にコピーしたいです！つまり
>　２つのSheetのみ保存させたいのですが・・
意味が把握できません。
もうすこし説明をしていただけないでしょうか。

ちょっと疑問があります。
ThisSheets.Save
の
ThisSheets
は何を表わしているのでしょうか。
これで上手く動いていますか？

補足

すいません！
以前、ここでブックそのままの
保存コピーを教えていただいたので
ThisWorkbook＝ThisSheetsに変えてみただけです！
安易なやり方なので
勿論動きません！
（２）は例えばSheet（"ko")上の
CommandButton1を作成しています！
そこをクリックすると
そのSheet（"ko")とSheet（"ti")の
2つのSheetのみが
保存コピーとして"D:\保存\ケア\計画\"
保存できるようにしたいです！
入力エクセルBookが重い（容量が大きい）為
Sheet２つだけフォルダにいれたいです！
入力エクセルは常に入力だけで（原本）

すいません！教えて下さい！

回答No.1

xls88

まず(1)について

>'(1)の質問！○＝の部分をSheets（セルのA1の値をファイル名に入れたいです）
>FileName = "○" & Format(Now, "yyyy-mm") & ".XLS"

下記のようにすればよいとおもいます。
FileName = Sheets("Sheet1").Range("A1").Value & Format(Now, "yyyy-mm") & ".XLS"

変数を使って
Dim celldata As String
celldata = Sheets("Sheet1").Range("A1").Value
FileName = celldata & Format(Now, "yyyy-mm") & ".XLS"
のようにすればスッキリします。

お礼

早速のお返事ありがとうございました！
（１）出来ました！
変数に関しても出来ました。
本当にすいません！（２）の方もお願いします。