８方向との数字の差が０か１の場合にセルを塗潰す方法

質問

どなたかご存知でしたら回答をお願いします。
【質問】
例題の様に6×6のセルが２つあり、それぞれ１~９９迄の数字がランダムに重複有りで入っています。
左上から右下へセルの数字を１つずつ中心にして見た場合、
８方向（上、下、左、右、右下、左下、右上、左上）の数字との差が０と１の場合に、
黄色に塗潰す方法が知りたいです。

【例題】
　A　Ｂ　Ｃ　Ｄ　Ｅ　Ｆ　Ｇ　Ｈ　Ｉ　Ｊ　Ｋ　Ｌ　Ｍ　
1 01　11　15　18　20　25　　 04　05　08　27　38　42
2 03　26　30　31　34　41 　　01　02　09　26　27　29
3 05　16　20　22　37　41 　　03　08　23　24　25　39
4 02　07　17　25　28　38 　　04　22　23　29　33　34
5 08　17　21　23　24　36 　　02　06　26　29　30　37
6 04　05　09　12　24　42 　　22　23　29　35　36　37

【結果】
A1~F6で塗る潰される数字　H1~M6で塗潰される数字　　　
30　31　41　　　　　　　　04　05　08　27
41　　　　　　　　　　　　01　02　09　26　27
25　　　　　　　　　　　　03　23　24　25　22
23　24　　　　　　　　　　23　29　33　34　29
04　05　24　　　　　　　　29　35　36　37
●説明
A1~F6で23、24（2か所）、25が塗潰される理由。
(1)セルD4の25から見た８方向にある数字は20、22、37、17、28、21、23、24なので、
　25との数字の差が０か１となる数字としては、24なので、24のセルが塗潰される。
(2)セルD5の23から見た８方向にある数字は17、25、28、21、24、9、12、24なので、
　23との数字の差が０か１となる数字としては24なので、右の24と右下の24のセルが
　塗潰される。
(3)セルE5の24から見た８方向にある数字は25、28、38、23、36、12、24、42なので、
　24との数字の差が０か１となる数字としては25と24なので、左上の25と下の24のセルが　塗潰される。
(4)セルE6の24から見た８方向にある数字は23、24、36、12、42なので、
　24との数字の差が０か１となる数字としては23と24なので、左上の23と上の24のセルが
　塗潰される。

【注意事項】
　・使用するエクセルは２０１０です。
　・セルの中の数字は２桁で表しています。（例：1ではなく01）
　・6×6のセルの位置は下記のとおりです。
　　　１個目の6×6マス・・・A1~F6
　　　２個目の6×6マス・・・H1~M6　
　　　※G列は空白列として空けています。　
　・回答はＶＢでも関数でも構いません。

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

回答No.2

SI299792 · ベストアンサー

全プログラムに獏がありました。B2とA1のような左斜めは無視されます。差し替えです。
'
Sub Macro1()
'
　　Dim Cell1 As Range
　　Dim Cell2 As Range
　　Dim RowF As Boolean
　　Dim ColF As Boolean

　　[A1:M6].Interior.Pattern = xlNone
'
　　For Each Cell1 In [A1:M6]
　　　　RowF = Cell1.Row > 1
　　　　ColF = Cell1.Column > 1
'
　　　　For Each Cell2 In Cell1.Offset(RowF, ColF).Resize(2 - RowF, 2 - ColF)
'
　　　　　　If Cell1 < "01" Or Cell2 < "01" Then
　　　　　　ElseIf Cell1.Address <> Cell2.Address And Abs(Cell2 - Cell1) < 2 Then
　　　　　　　　Cell1.Interior.Color = vbYellow
　　　　　　　　Exit For
　　　　　　End If
　　　　Next Cell2
　　Next Cell1
End Sub

回答No.6

neKo_quatre

> ８方向（上、下、左、右、右下、左下、右上、左上）の数字との差が０と１の場合に、

端っこの処理が面倒なので、0や99と２以上の差がある数で埋めとくのが良いかも。
　 A　 Ｂ　 Ｃ　 Ｄ
1 -99　-99　-99　-99
2 -99　 01　 11　 15
3 -99　 03　 26　 30

式が長くなるけど、フツーに条件付き書式を設定すれば良いのでは。
上のB2セルだと、
=OR((ABS(B2-A1)<=2), (ABS(B2-B1)<=2), (ABS(B2-C1)<=2), (ABS(B2-A2)<=2), (ABS(B2-C2)<=2), (ABS(B2-A3)<=2), (ABS(B2-B3)<=2), (ABS(B2-C3)<=2))
とか。

お礼

はじめまして。
回答頂きありがとうございます。
条件付き書式を駆使すれば可能性ありなんですね。

回答No.5

msMike

確認させてください。
類似の質問を延々と続けられていますが、何か“超難問クイズ”擬きの作成をしておられるのでしょうか？

お礼

いつも回答頂きありがとうございます。
＞何か“超難問クイズ”擬きの作成をしておられるのでしょうか？　
それを解くためにエクセルの可能性を探っています。
皆さんのお力を拝借して。

回答No.4

watabe007

訂正
Range("A1:M11").Interior.Color = xlNone
　　　　↓
Range("A1:M6").Interior.Color = xlNone

お礼

いつも回答頂きありがとうございます。
また、無駄のないソースとバリエーションも豊富ですね。
またよろしくお願いします。

回答No.3

watabe007

Sub Test()
　　Dim c As Range, i As Long, n As Long
　　Dim arrR As Variant, arrC As Variant

　　Range("A1:M11").Interior.Color = xlNone
　　arrR = Array(0, 0, 0, 1, 1, 2, 2, 2)
　　arrC = Array(0, 1, 2, 0, 2, 0, 1, 2)
　　On Error Resume Next
　　For Each c In Range("A1:M6")
　　　　For i = 0 To 7
　　　　　　With c.Cells(arrR(i), arrC(i))
　　　　　　　　n = Val(c.Value) - Val(.Value)
　　　　　　　　If (Abs(n) = 1 Or Abs(n) = 0) And _
　　　　　　　　　　(.Column <> 7 And .Column <> 14 And .Row <> 7) Then
　　　　　　　　　　.Interior.Color = vbYellow
　　　　　　　　End If
　　　　　　End With
　　　　Next
　　Next
　　On Error GoTo 0
End Sub

回答No.1

SI299792

B3が16でC4が17だから、塗りつぶしの対象ではないですか。
K1が27、K2が26、上より下が小さい場合は塗りつぶしの対象ですか？（対象としました）
よく観察すると、ほとんどに差が０か１のところがあり、塗りつぶされます。
'
Sub Macro1()
'
　　Dim Cell1 As Range
　　Dim Cell2 As Range

　　[A1:M6].Interior.Pattern = xlNone
'
　　For Each Cell1 In [A1:M6]
'
　　　　For Each Cell2 In Cell1.Resize(2, 2)
'
　　　　　　If Cell1 < "01" Or Cell2 < "01" Then
　　　　　　ElseIf Cell1.Address <> Cell2.Address And Abs(Cell2 - Cell1) < 2 Then
　　　　　　　　Cell1.Interior.Color = vbYellow
　　　　　　　　Cell2.Interior.Color = vbYellow
　　　　　　　　Exit For
　　　　　　End If
　　　　Next Cell2
　　Next Cell1
End Sub

前回のリベンジです。
前回うまくいかなかったのは、Ｆ列にスペースなど見えない文字が入っていたのだと思います。
今回はスペースが入っていても動くようにしました。

参考URL：

https://okwave.jp/qa/q9549901/a26667546.html

お礼

いつも回答頂きありがとうございます。
＞B3が16でC4が17だから、塗りつぶしの対象ではないですか。
　ご指摘頂きありがとうございます。
　目で見てるとやっぱり漏れてしまうものですね。
　だからエクセルが必要なんです。