こんにちはゲストさん。会員登録(無料)して質問・回答してみよう!

解決済みの質問

エクセル 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
教えて下さい!

投稿日時 - 2008-09-02 18:09:26

QNo.4298405

すぐに回答ほしいです

質問者が選んだベストアンサー

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

  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

投稿日時 - 2008-09-02 23:47:46

補足

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

投稿日時 - 2008-09-03 00:24:50

ANo.3

このQ&Aは役に立ちましたか?

0人が「このQ&Aが役に立った」と投票しています

回答(5)

ANo.5

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

投稿日時 - 2008-09-03 13:23:54

お礼

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

投稿日時 - 2008-09-04 15:27:38

ANo.4

保存先も同じくパスワードを掛けるなら、以下のように追加・変更してください。
ちなみに、オートシェイプのなかに「ボタン」以外は全て残すなら、ボタンのみ削除すればいいと思います。
※オートシェイプの種類は以下のように、「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"       '←シートに保護を掛ける

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

投稿日時 - 2008-09-03 09:27:33

補足

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

投稿日時 - 2008-09-03 12:00:52

ANo.2

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

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

投稿日時 - 2008-09-02 20:23:52

補足

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

投稿日時 - 2008-09-02 21:53:06

ANo.1

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

投稿日時 - 2008-09-02 18:20:08

補足

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

投稿日時 - 2008-09-02 19:00:22

お礼

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

投稿日時 - 2008-09-02 19:10:35

あなたにオススメの質問