【再】連続する同じ数字のセルの塗り潰しがしたい。

質問

先程は、質問の添付図が添付されていなかたので再掲載します。
＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠
このカテゴリーのエクセルの達人の方々に質問です。
どなたか回答して頂ける方がお見えでしたら回答よろしくお願いします。
（ちゃんとした回答ではなく、文句やクレーム等を混ぜた記載はご遠慮ください。
　また私の質問が気に入らない場合は無視して頂ければ結構です。）
【質問】
　添付図のとおり、４行×２５列の中に数字が１～31まであり、重複して入っています。
　この中にある数字で、同じ数字が縦・右斜め・左斜め（横は無い）のいずれかに該当すれば
　その数字のセルを黄色で塗り潰す方法をＶＢＡで実現する方法が知りたいです。

【注意事項】
　　・４行×２５列の中にある数字の並びは毎回異なります。
　　・ＶＢＡで実現する方法～、と書きましたが、
　　　同様のことが他の方法でも実現できればそれを教えて下さい。
　　・使用するエクセルは２０２１です。

以上、よろしくお願いします。

回答No.3

kkkkkm · ベストアンサー

VBAだと(冗長なコードかもしれませんが思いつくままのコードです)
実行時の画像は回答No.2と同じなので省略します。

Sub Test()
Dim i As Long
Dim c As Range

Range("A1:Y4").Interior.ColorIndex = xlNone

For Each c In Range("A1:Y4")
If c.Row <> 1 And c.Column <> 1 Then
If c.Value = c.Offset(-1, -1).Value _
Or c.Value = c.Offset(-1, 0).Value _
Or c.Value = c.Offset(-1, 1).Value _
Or c.Value = c.Offset(1, -1).Value _
Or c.Value = c.Offset(1, 0).Value _
Or c.Value = c.Offset(1, 1).Value _
Then
c.Interior.Color = vbYellow
End If
ElseIf c.Row = 1 Then
If c.Column <> 1 Then
If c.Value = c.Offset(1, 0).Value _
Or c.Value = c.Offset(1, 1).Value _
Or c.Value = c.Offset(1, -1).Value _
Then
c.Interior.Color = vbYellow
End If
Else
If c.Value = c.Offset(1, 0).Value _
Or c.Value = c.Offset(1, 1).Value _
Then
c.Interior.Color = vbYellow
End If
End If
ElseIf c.Column = 1 Then
If c.Row <> 1 Then
If c.Value = c.Offset(1, 0).Value _
Or c.Value = c.Offset(1, 1).Value _
Or c.Value = c.Offset(-1, 0).Value _
Or c.Value = c.Offset(-1, 1).Value _
Then
c.Interior.Color = vbYellow
End If
End If
End If
Next
End Sub

お礼

ＶＢＡ実行して上手くいきました。 ありがとうございます。

Powered by GRATICA