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

質問

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

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

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

回答No.1

watabe007 · ベストアンサー

参考に
Sub Test2()
　　Dim i As Long, j As Long, c As Range, c2 As Range
　　Dim Area1 As Range, Area2 As Range
　　Application.ScreenUpdating = False
　　ActiveSheet.Rows(1).Insert
　　ActiveSheet.Columns(1).Insert
　　Set Area1 = Range("R5:AK10")
　　Set Area2 = Range("R12:AK17")
　　Area1.ClearContents
　　Area2.ClearContents
　　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
　　　　For Each c In .Cells
　　　　　　If c.Interior.Color = vbYellow Then
　　　　　　　　If c.Column < 9 Then
　　　　　　　　　　i = i + 1
　　　　　　　　　　Area1.Item(i).Value = c.Value
　　　　　　　　Else
　　　　　　　　　　j = j + 1
　　　　　　　　　　Area2.Item(j).Value = c.Value
　　　　　　　　End If
　　　　　　End If
　　　　Next
　　End With
　　ActiveSheet.Rows(1).Delete
　　ActiveSheet.Columns(1).Delete
　　Application.ScreenUpdating = True
End Sub

お礼

早速のご回答ありがとうございます。
やりたいことができました。
またよろしくお願いいたします。