質問をすることでしか得られない、回答やアドバイスがある。

15分調べてもわからないことは、質問しよう!

ただいまの
回答率

91.03%

  • VBA

    1414questions

    VBAはオブジェクト指向プログラミング言語のひとつで、マクロを作成によりExcelなどのOffice業務を自動化することができます。

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

解決済

回答 3

投稿 編集

  • 評価
  • クリップ 0
  • VIEW 322

イメージ説明
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についても検証しましたが、解消が見いだせません。

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

  • 気になる質問をクリップする

    クリップした質問は、後からいつでもマイページで確認できます。

    またクリップした質問に回答があった際、通知やメールを受け取ることができます。

    クリップを取り消します

  • 良い質問の評価を上げる

    以下のような質問は評価を上げましょう

    • 質問内容が明確
    • 自分も答えを知りたい
    • 質問者以外のユーザにも役立つ

    評価が高い質問は、TOPページの「注目」タブのフィードに表示されやすくなります。

    質問の評価を上げたことを取り消します

  • 評価を下げられる数の上限に達しました

    評価を下げることができません

    • 1日5回まで評価を下げられます
    • 1日に1ユーザに対して2回まで評価を下げられます

    質問の評価を下げる

    teratailでは下記のような質問を「具体的に困っていることがない質問」、「サイトポリシーに違反する質問」と定義し、推奨していません。

    • プログラミングに関係のない質問
    • やってほしいことだけを記載した丸投げの質問
    • 問題・課題が含まれていない質問
    • 意図的に内容が抹消された質問
    • 広告と受け取られるような投稿

    評価が下がると、TOPページの「アクティブ」「注目」タブのフィードに表示されにくくなります。

    質問の評価を下げたことを取り消します

    この機能は開放されていません

    評価を下げる条件を満たしてません

    評価を下げる理由を選択してください

    詳細な説明はこちら

    上記に当てはまらず、質問内容が明確になっていない質問には「情報の追加・修正依頼」機能からコメントをしてください。

    質問の評価を下げる機能の利用条件

    この機能を利用するためには、以下の事項を行う必要があります。

質問への追記・修正、ベストアンサー選択の依頼

  • hihijiji

    2017/11/09 16:33

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

    キャンセル

  • vitabrevisarsl1

    2017/11/09 17:48

    ・追記いたしました。

    キャンセル

  • h.horikoshi

    2017/11/10 10:12

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

    キャンセル

  • vitabrevisarsl1

    2017/11/10 11:47

    Excel2013です。

    キャンセル

回答 3

+2

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

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


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

投稿

  • 回答の評価を上げる

    以下のような回答は評価を上げましょう

    • 正しい回答
    • わかりやすい回答
    • ためになる回答

    評価が高い回答ほどページの上位に表示されます。

  • 回答の評価を下げる

    下記のような回答は推奨されていません。

    • 間違っている回答
    • 質問の回答になっていない投稿
    • スパムや攻撃的な表現を用いた投稿

    評価を下げる際はその理由を明確に伝え、適切な回答に修正してもらいましょう。

checkベストアンサー

+1

質問のほうに「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ボタンあるいはシェイプ(図形)で作られたほう無難だと思います。

投稿

  • 回答の評価を上げる

    以下のような回答は評価を上げましょう

    • 正しい回答
    • わかりやすい回答
    • ためになる回答

    評価が高い回答ほどページの上位に表示されます。

  • 回答の評価を下げる

    下記のような回答は推奨されていません。

    • 間違っている回答
    • 質問の回答になっていない投稿
    • スパムや攻撃的な表現を用いた投稿

    評価を下げる際はその理由を明確に伝え、適切な回答に修正してもらいましょう。

+1

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)でボタンを特定しようとしている箇所がうまく機能していないのではないかとと推測しています。
といってもこちらでは現象が出ていないので野生の勘なのですが。

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

投稿

  • 回答の評価を上げる

    以下のような回答は評価を上げましょう

    • 正しい回答
    • わかりやすい回答
    • ためになる回答

    評価が高い回答ほどページの上位に表示されます。

  • 回答の評価を下げる

    下記のような回答は推奨されていません。

    • 間違っている回答
    • 質問の回答になっていない投稿
    • スパムや攻撃的な表現を用いた投稿

    評価を下げる際はその理由を明確に伝え、適切な回答に修正してもらいましょう。

15分調べてもわからないことは、teratailで質問しよう!

  • ただいまの回答率 91.03%
  • 質問をまとめることで、思考を整理して素早く解決
  • テンプレート機能で、簡単に質問をまとめられる

関連した質問

同じタグがついた質問を見る

  • VBA

    1414questions

    VBAはオブジェクト指向プログラミング言語のひとつで、マクロを作成によりExcelなどのOffice業務を自動化することができます。