ボタンが消えない？

Question

win7、office2007です。

列の最後尾にボタンを一つ配置しています。キャプション「追加」となっています。

ボタンをクリックすると、その行丸ごとコピーしてすぐ下にペーストします。その際、ボタンもコピーしますが、キャプションを「削除」にします。

「削除」ボタンをクリックするとそのボタンのある行全体が削除され、その下の行が上に詰めてくれます。

という動きを考えています。

以下のようなプログラムを考えてみたところ、

目的の行全体は削除され、下の行が詰めてくれるのですが、ボタンが消え図に残っています。詰めてきた下の行に食い込んでる状態。

奇妙なのは、デバッグモードで１行づつ動かしていると、ボタンが消えてくれる場合がある、ということ。

でもできない場合もあり、普通に実行すると消えません。ステップインを一つ一つ時間をかけるとうまくいくような気が....(^_^;)

わたしにはわけがわからないのですが、解決になにかヒントをいただけるとありがたいです。

（ボタンはリボン＞開発＞コントロール＞挿入＞フォームコントロールの左上のボタンです）

よろしくお願いします。

Sub AddList()

Dim oBTN As Button

Set oBTN = ActiveSheet.Buttons(Application.Caller)

'vBTN = ActiveSheet.Shapes(Application.Caller).TopLeftCell.Row 'フォームボタンの置かれているアドレスを取得

vBTN = oBTN.TopLeftCell.Row 'フォームボタンの置かれているアドレスを取得

If oBTN.Caption = "素材削除" Then

    oBTN.Delete　　　←効きません

    'oBTN.Select　　　←delete でうまくいかないのでセレクトしてカットしてみましたが同じでした。

    'Selection.Cut

    Rows(vBTN).Delete　　←行削除は成功します。

Else: Call Tuika(oBTN, vBTN)　　←追加は下に続きます

End If

end Sub

Private Sub Tuika(ByVal oBTN As Button, ByVal vBTN As Variant)

oBTN.Caption = "削除"　　←最初に削除とつけておきます

Rows(vBTN).Copy　’行全体をコピー

Cells(vBTN + 1, 1).EntireRow.Insert　'行全体を下にシフト

Rows(vBTN).Copy Destination:=Rows(vBTN + 1)　'行の挿入

If vBTN = 10 Then　'ボタン名を「削除」に。'もし一番上（10）なら「追加」に。

 　oBTN.Caption = "追加"

Else: oBTN.Caption = "削除"

End If

End Sub

Answer 1

返答ありがとうございます（１３日から風邪ひいて寝込んでましたのでまったく未解決でした(^_^;)

＞『 Rows(vBTN).Copy 』 を２回実施していることが動作不良の原因ではないでしょうか。

これに気付いていませんでした。確かに削除すれば思った通りに動作します。助かりました！

＞With ActiveSheet.Buttons(Application.Caller)

これでまとめることができるということをいつも忘れてるんですよね。

教えていただいたやり方で、非常に簡単なコードになりました。

ありがとうございました(^_^)

Answer 2

こんにちは。

もう解決済みかもしれませんが、気になりましたので、お書きになられているコードを実行確認してみました。

『 Rows(vBTN).Copy 』 を２回実施していることが動作不良の原因ではないでしょうか。

「行全体をコピー」 とコメントを付けられているほうを削除することで動作するかと思います。

尚、『 If oBTN.Caption = "素材削除" Then 』 の箇所は、"素材削除" ではなく "削除" ですよね。

これから、コードを整理して仕上げられるのかと思いますが、書き方を変えると下記のようにもできました。

何かのご参考になれば幸いです。

（このコードは、キャプションを 「追加」 に変更した 「ボタン」 に 「マクロの登録」 で割り当てて動作確認しました。）

Sub UniButton_Click()

  With ActiveSheet.Buttons(Application.Caller)

    If .Caption = "追加" Then

      .Caption = "削除"

      Rows(.TopLeftCell.Row + 1).Insert

      Rows(.TopLeftCell.Row).Copy (Rows(.TopLeftCell.Row + 1))

      .Caption = "追加"

    Else

      Rows(.TopLeftCell.Row).Delete

      .Delete

    End If

  End With

End Sub