Select - Case - If のループが同じところを繰り返してしまう 問題

Question

B列に「▲」と「▼」ボタンが並んでいます。この内一番上と一番下のボタンを非アクティブにしたいです。
非アクティブにするために無動作マクロを割り当てるのですが、TopLeftCellを使い各ボタンのRow番取得がうまく行きません。
F8で検証するに、上図のように同じ「▲」と「▼」ボタンのループだけで終了してしまう場合があります。

Sub 最上最下ボタン無効()
Dim q As Integer
Dim r As Integer
Dim btn As Shape

Application.ScreenUpdating = False 'チラついて五月蝿いのを防止

Worksheets("年間集計_出勤簿").Activate

Worksheets("年間集計_出勤簿").Unprotect

'シート内のすべてのオブジェクト（シェイプ）をループ処理
For Each btn In ActiveSheet.Shapes
    Select Case btn.AlternativeText '取得したオブジェクトを表示名で判別
    Case "▲"
        q = ActiveSheet.Shapes(btn.Name).TopLeftCell.Row
        If q = 8 Then
            ActiveSheet.Shapes(btn.Name).Select
            Debug.Print "無効ボタンアクション▲ q = 8"
            With Selection
                .OnAction = "無効ボタンアクション"
                .Font.ColorIndex = 15
            End With
        Else
            Debug.Print q & ":" & ActiveSheet.Shapes(btn.Name).TopLeftCell.Row
            ActiveSheet.Shapes(btn.Name).Select
            With Selection
                .OnAction = "上に行移動"
                .Font.ColorIndex = 56
            End With
        End If
    Case "▼"
        r = btn.TopLeftCell.Row
        If r + 4 = ActiveSheet.Range("a8:a" & Cells(Rows.Count, 1).End(xlUp).Row).Count + 7 Then
            ActiveSheet.Shapes(btn.Name).Select
            Debug.Print "無効ボタンアクション▼ r + 4 =" & r & " // " & ActiveSheet.Range("a8:a" & Cells(Rows.Count, 1).End(xlUp).Row).Count + 7
            ActiveSheet.Shapes(btn.Name).OnAction = "無効ボタンアクション"
            With Selection
                .OnAction = "無効ボタンアクション"
                .Font.ColorIndex = 15
            End With
        Else
        Debug.Print r + 4 & ":" & ActiveSheet.Range("A8:A" & Cells(Rows.Count, 1).End(xlUp).Row).Count + 7
            ActiveSheet.Shapes(btn.Name).Select
            With Selection
                .OnAction = "下に行移動"
                .Font.ColorIndex = 56
            End With
        End If

    End Select
Next

Worksheets("年間集計_出勤簿").Protect UserInterfaceOnly:=True
Worksheets("年間集計_出勤簿").Range("C3:D3").Locked = False

ActiveSheet.Range("C3").Select
Application.ScreenUpdating = True

End Sub

カウンタ変数をiから他の文字に変えると順番に全部ループにかかりますが、一旦ファイル保存した後開いて再検証すると再発します。
Case - if の実行の中身をdebug.print等にすると問題ないことから、With Selection 以下がおかしいのかと思いdebug.print等より単純なものに替えてみると問題ありません。
OnActionとFont.Color.Indexについても検証しましたが、解消が見いだせません。

何かヒントでもご教授いただけますと幸いです。

Comments

[hihijiji]

コードは画像を貼らずに Markdown で書いてください。

[vitabrevisarsl1]

・追記いたしました。

[h.horikoshi]

Excelのバージョン(20xx)は何ですか? 2007以降、AlternativeTextでは表示名が採取できないように思いますが...

[vitabrevisarsl1]

Excel2013です。

Answer 1

今回の原因であるかは分かりませんが、ActiveSheet は変動することを留意してください。
MDIだった Excel 2010 以前から不変ではありませんでしたが、SDIになってから顕著に変わるようです。
ActiveSheet を使うと必ずいつかはトラブりますので、使わないようにしてください。

Dim yearlyAttendanceSheet As Worksheet
Set yearlyAttendanceSheet = Worksheets("年間集計_出勤簿")

こんな風に解り易い？名前を付けて操作してください。

Answer 2

質問のほうに「AlternativeTextでは表示名が採取できないように思いますが...」
などと書いてしまいましたが、AlternativeTextで値が採取できているということは、ボタンはフォームボタンで作成されていると考えてよいですか?

その前提でプログラムを書き直してみました。

Dim topIx As Long: topIx = 1                	' 最も上にあるボタンのIndex。デフォルト=1
Dim btmIx As Long: btmIx = 1                	' 最も下にあるボタンのIndex。デフォルト=1
Dim ss As Object: Set ss = ActiveSheet.Shapes	' 面倒なので変数に入れる
Dim ix As Long
For ix = 1 To ss.Count
  ' (1)とりあえず▲▼ボタンは全て有効にする。
  ' (2)最も上のボタンと最も下のボタンのIndexを求める。
  Select Case (ss(ix).AlternativeText)
    Case "▲": '---------------------------------------------------------------
               ss(ix).OnAction = "上に行移動"
               ss(ix).TextFrame.Characters.Font.ColorIndex = 56	' ※
               If (ss(ix).TopLeftCell.Row < ss(topIx).TopLeftCell.Row) Then topIx = ix
    Case "▼": '---------------------------------------------------------------
               ss(ix).OnAction = "下に行移動"
               ss(ix).TextFrame.Characters.Font.ColorIndex = 56 ' ※
               If (ss(ix).TopLeftCell.Row > ss(btmIx).TopLeftCell.Row) Then btmIx = ix
  End Select
Next ix
  ' 最も上のボタンと最も下のボタンを無効に書き替える。
  ss(topIx).OnAction = "無効ボタンアクション"
  ss(topIx).TextFrame.Characters.Font.ColorIndex = 15   ' ※ 
  ss(btmIx).OnAction = "無効ボタンアクション"
  ss(btmIx).TextFrame.Characters.Font.ColorIndex = 15   ' ※

【注】「※」の部分はExcel2010版用の記述です。非互換があるようですので
2013版用の記述に変更してください。

なお、フォームボタンはバージョン間でかなり非互換があるようですし、自由度も小さいため、ボタンはActiveXボタンあるいはシェイプ(図形)で作られたほう無難だと思います。

Answer 3

For Each btn In ActiveSheet.Shapes ～ Nextで同じボタンを複数回してしまうとはちょっと考えにくいですね。
こちらの環境でも提示いただいたコードを数回試してみましたが、同じボタンが複数回取得されてしまうような現象は発生しませんでした。

本当に同じボタンが複数回取得されてしまっているのか、はたまたそれ以外の箇所に問題があるのか、見極めるためにもまずは簡単なコードで動作を確認してみることをオススメします。
例えば以下のような簡潔なコードで試してみてください。

Sub test()
    For Each btn In ActiveSheet.Shapes
        Debug.Print btn.AlternativeText & " " & CStr(btn.TopLeftCell.Row)
    Next
End Sub

これでも同じ行番号のボタンが複数回取得されるのであれば、For Eachに問題があるのかもしれません。
この処理では同じボタンが複数回処理されないのであれば、それ以外の処理に問題があるのだと思います。
おそらくActiveSheet.Shapes(btn.Name)でボタンを特定しようとしている箇所がうまく機能していないのではないかとと推測しています。
といってもこちらでは現象が出ていないので野生の勘なのですが。

まずはコードをお試しください。