エクセル VBA シート保存ボタン

質問

Sheet上にボタンを作成
ボタンを押すと保存するようにしています！
以前ここでSheet2枚をコピー出来るような
記述教えてもらったのですが・・
1枚ならどう変化して良いか・・
記述を書きましたが
何処が違うか教えて下さい！
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"

　　'
　　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)).Copy
　　Set NewWkbook = ActiveWorkbook
　　For wIx = 1 To NewWkbook.Sheets(1).Shapes.Count
　　　　NewWkbook.Sheets(1).Shapes(wIx).Delete　
　　Next
　　NewWkbook.Sheets(1).Name = StName1
　　'
　　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
教えて下さい！

回答No.3

pkh4989 · ベストアンサー

以下のように変更してみてください。

　　Set NewWkbook = ActiveWorkbook
　　NewWkbook.Unprotect Password:=""
　　For wIx = NewWkbook.Sheets(1).Shapes.Count To 1 Step -1
　　　　 If Left(NewWkbook.Sheets(1).Shapes(wIx).Name, 5) <> "Chart" Then　'グラフ以外は削除
　　　　　　NewWkbook.Sheets(1).Shapes(wIx).Delete
　　　　End If
　　Next

補足

ありがとうございました！
本当に感謝しています。
すいません
質問ばっかりで
(1)NewWkbook.Unprotect Password:="１１１１"
例えば”１１１１”と設定しても
保存先のファイルには
何も変化はないのですが・・
これはどういう設定なのでしょうか？
(2) "Chart" Then　'グラフ以外は削除
ですが、オートシェイプの図形なども
消さない為には
””の中に何かを記述すれば
出来るものなのでしょうか？
いつも本当にありがとうございます！

回答No.5

pkh4989

すみません。
以下のように変更してみてください。
ちなみに、オートシェイプについては、私もシート上になにがあるか分かりませんので
自分で調べてください。
※調べる方法
　　For wIx = 1 To ActiveSheet.Shapes.Count
　　　　 MsgBox ActiveSheet.Shapes(wIx).Name　　　　'←オートシェイプの名称が表示される
　　Next
　　'ボタンが２個の場合
　　「Button 1」、「Button 2」のように表示されると思います。
　　この２個のボタンのみ削除するには以下のようにしてもいいです。

　　For wIx = ActiveSheet.Shapes.Count To 1 Step -1
　　　　 If ActiveSheet.Shapes(wIx).Name = "Button 1" or_
　　　　　　ActiveSheet.Shapes(wIx).Name = "Button 2" Then_
　　　　　　ActiveSheet.Shapes(wIx).Delete
　　　　End If
　　Next
　　又は
　　For wIx = ActiveSheet.Shapes.Count To 1 Step -1
　　　　 If left(ActiveSheet.Shapes(wIx).Name,6) = "Button" Then
　　　　　　ActiveSheet.Shapes(wIx).Delete
　　　　End If
　　Next

'--------------------------------------------------------↓(変更部分)
　　OldWkbook.Sheets(Array(StName1)).Copy
　　Set NewWkbook = ActiveWorkbook
　　ActiveSheet.Unprotect Password:="1111"　　　　　'←シートの保護を解除(ActiveSheetに変更)
　　For wIx = NewWkbook.Sheets(1).Shapes.Count To 1 Step -1
　　　　 If Left(NewWkbook.Sheets(1).Shapes(wIx).Name, 6) = "Button" Then　'ボタンのみ削除
　　　　　　NewWkbook.Sheets(1).Shapes(wIx).Delete　'←1ではなくwIxです
　　　　End If
　　Next
　　NewWkbook.Sheets(1).Name = StName1
　　ActiveSheet.Protect Password:="1111"　　　　　　'←シートに保護を掛ける(ActiveSheetに変更)
'--------------------------------------------------------↑(変更部分)

お礼

pkh4989さん
本当にありがとうございます！
本当に感謝しております！
またこんなに親切なアドバイスを
いつもありがとうございました。
また教えて下さい！
オートシェイプの名称の
探し方も
今後も使っていきます！

回答No.4

pkh4989

保存先も同じくパスワードを掛けるなら、以下のように追加・変更してください。
ちなみに、オートシェイプのなかに「ボタン」以外は全て残すなら、ボタンのみ削除すればいいと思います。
※オートシェイプの種類は以下のように、「NewWkbook.Sheets(1).Shapes(wIx).Name」で
　　調べるしかないと思います。
　　削除したいオートシェイプがボタン以外にもあるなら、以下のように「or」で条件を追加すればいいです。
　　'If Left(NewWkbook.Sheets(1).Shapes(wIx).Name, 6) = "Button" or _
　　'　　NewWkbook.Sheets(1).Shapes(wIx).Name = "Organization Chart 2" then

　　Set NewWkbook = ActiveWorkbook
　　NewWkbook.Unprotect Password:="1111"　　　　　　'←シートの保護を解除
　　For wIx = NewWkbook.Sheets(1).Shapes.Count To 1 Step -1
　　　　 If Left(NewWkbook.Sheets(1).Shapes(wIx).Name, 6) = "Button" Then　'ボタンのみ削除
　　　　　　NewWkbook.Sheets(1).Shapes(wIx).Delete
　　　　End If
　　Next
　　NewWkbook.Protect Password:="1111"　　　　　　　'←シートに保護を掛ける

以上、頑張ってください。

補足

pkh4989さん
いつも親切な回答本当にありがとうございます！
私の勉強不足なのですが・・・
(1)
"Button" Then　'ボタンのみ削除Button（名前はグラフ保存）
してもオートシェイプが
も消えてしまいます！
何がいけないのでしょうか？
(2)シートのオブジェクト解除して
Unprotect Password:="1111"　　　　　　'←シートの保護を解除
Protect Password:="1111"　　　　　　　'←シートに保護を掛ける
何も変化がないです！
本当にすいません！
(1)は別に消したくなかったら
オートシェイプをやめて
セルに直接記入しておけば
良いのですが・・ボタンを消せて良かったです！が
今回の件が
気になります！すいません
もう少しお付き合いして下さい！

回答No.2

pkh4989

以下のように追加してください。
シートの保護を解除しなければなりません。

　　NewWkbook.Unprotect Password:="password"　　　　'←パスワードを解除(パスワードを入れてください)
　　For wIx = 1 To NewWkbook.Sheets(1).Shapes.Count
　　　　NewWkbook.Sheets(1).Shapes(1).Delete
　　Next

補足

ありがとうございます！
シートのオブジェクト
を解除して
記述を直しました！
エラー表示はなく
コピーできましたが
保存フォルダを開いてコピーしたものを
見ると
ボタンは消えていましたが
グラフの表も消えていました！
こういう現象の時にはどのようにすれば
良いのでしょうか？

回答No.1

pkh4989

こんにちは。
For wIx = 1 To NewWkbook.Sheets(1).Shapes.Count
NewWkbook.Sheets(1).Shapes(1).Delete '←wIxを1に変更
Next

お礼

Sheetの保護でオブジェクトのみ
保護をかけています！
それを解除すると上手くコピー
出来るのですが・・
方法は、Sheetの保護解除しか
ないのでしょうか？

補足

ありがとうございます！
すいません！いつも！
１に変更しても
実行時エラー１００４
アプリケーション定義または
オブジェクト定義のエラーです！
と表示されます。
どうしてなんでしょうか？