８方向の数字間差が指定した間差と同じ場合に塗り潰す

質問

いつもお世話になっております。
どなたかご存知の方がおられましたら回答をよろしくお願い致します。
【質問】
　添付図のとおり、A1～G15、I1～O15迄1～９９迄の数字が重複在りで入って
　います。Ｑ１に”数字間差”としてＲ１に数字間差を指定します。
　Ａ１のセルの数字から右側順番に８方向に隣り合う数字との差がＲ１に指定した
　数字間差と一致した場合にセルを黄色に塗り潰す方法が知りたいです。
〇塗りつぶしの例１（添付図参照）
　Ａ１：1の場合、隣り合う８方向の数字としては、Ｂ１、A2、Ｂ２の３つしか
　無く、Ｂ１-Ａ１、Ａ２-Ａ１、Ｂ２-Ａ１としても数字間差の７にはならないため
　塗りつぶしは無い。
〇塗りつぶしの例２（添付図参照）
　Ｊ５：６の場合、隣り合う８方向の数字としては、Ｉ４、Ｊ４、Ｋ４、Ｉ５、
　Ｉ６、Ｊ６、Ｋ６、Ｋ５の８つあり。Ｉ４-Ｊ５、Ｊ４-Ｊ５、Ｋ４-Ｊ５、
　Ｉ５-Ｊ５、Ｉ６-Ｊ５、Ｊ６-Ｊ５、Ｋ６-Ｊ５、Ｋ５-Ｊ５で数字間差が７となる
　Ｋ５、Ｉ６が黄色く塗り潰される。

【注意事項】
　・使用するエクセルは２０１６です。
　・数字間差で指定するのは１～９９迄です。

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

回答No.2

watabe007 · ベストアンサー

参考に
Sub Test()
　Dim i As Long, j As Long, c As Range, c2 As Range

　Application.ScreenUpdating = False
　ActiveSheet.Rows(1).Insert
　ActiveSheet.Columns(1).Insert
　With Range("B2:H16,J2:P16")
　　.Interior.Color = xlNone
　　For Each c In .Cells
　　　For Each c2 In Intersect(c.Offset(-1, -1).Resize(3, 3), .Cells)
　　　　If c.Address <> c2.Address And Abs(c.Value - c2.Value) = Range("S2").Value Then
　　　　　c2.Interior.Color = vbYellow
　　　　End If
　　　Next
　　Next
　End With
　ActiveSheet.Rows(1).Delete
　ActiveSheet.Columns(1).Delete
　Application.ScreenUpdating = True
End Sub

お礼

回答いただきありがとうございます。
早速、ソースを実行したところ、
やりたい通りの塗りつぶしができました。
ついでに添付図のB13が塗り潰しの間違いがわかりました。

回答No.1

HohoPapa

H列、P列、及び16行目は全数Null:空欄という条件でよければ
次のようなコードで行けると思います。

なお、なにか事情があって
1行目、あるいは1列目からデータを埋めているのかもしれませんが
こういった場合、1列目、1行目を空ければ、
余計なエラー処理を施さなくとも済みます。

Option Explicit

Sub Sample()

　Dim SRow As Long
　Dim SCol As Long
　Dim ERow As Long
　Dim ECol As Long
　Dim KeyNum As Long
　Dim RowCnt As Long
　Dim ColCnt As Long

　With ThisWorkbook.Sheets(1)

　　KeyNum = .Cells(1, 18).Value
　　SRow = 1　　　 '以下左側ブロック
　　SCol = 1
　　ERow = 15
　　ECol = 7

　　For RowCnt = SRow To ERow
　　　For ColCnt = SCol To ECol
　　　　MySub .Cells(RowCnt, ColCnt), KeyNum
　　　Next ColCnt
　　Next RowCnt

　　SRow = 1　　　　'以下右側ブロック
　　SCol = 9
　　ERow = 15
　　ECol = 15

　　For RowCnt = SRow To ERow
　　　For ColCnt = SCol To ECol
　　　　MySub .Cells(RowCnt, ColCnt), KeyNum
　　　Next ColCnt
　　Next RowCnt

　End With

End Sub

Sub MySub(adr As Range, KeyNum As Long)
　Dim RowCnt As Long
　Dim ColCnt As Long
　For RowCnt = -1 To 1
　　For ColCnt = -1 To 1
　　　On Error Resume Next
　　　If (((ColCnt <> 0) Or (RowCnt <> 0)) And _
　　　　　(adr.Offset(RowCnt, ColCnt).Value <> "") And _
　　　　　(adr.Offset(RowCnt, ColCnt).Value - adr.Value = KeyNum)) Then
　　　　adr.Offset(RowCnt, ColCnt).Interior.Color = rgbYellow
　　　End If
　　　On Error GoTo 0
　　Next ColCnt
　Next RowCnt
End Sub

補足

早速のご回答ありがとうございます。
教えて頂いて恐縮ですが、説明不足があるので補足します。
数字間差としてＲ１の数字と同じであれば黄色に塗り潰すと言ってますが、
教えて頂いたＶＢＥを実行しても添付図と同じ数だけ塗り潰しがされないです。
それは、減算をして数字間差が＋７の場合のみしか塗り潰さないためかなと思います。
減算して数字間差がー７の場合でも黄色に塗り潰す様にしないと添付図と同じ結果にならないのかと思います。