こんにちはゲストさん。会員登録(無料)して質問・回答してみよう!

解決済みの質問

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

いつもお世話になっております。
どなたかご存知の方がおられましたら回答をよろしくお願い致します。
【質問】
 添付図のとおり、A1~G15、I1~O15迄1~99迄の数字が重複在りで入って
 います。Q1に”数字間差”としてR1に数字間差を指定します。
 A1のセルの数字から右側順番に8方向に隣り合う数字との差がR1に指定した
 数字間差と一致した場合にセルを黄色に塗り潰す方法が知りたいです。
〇塗りつぶしの例1(添付図参照)
 A1:1の場合、隣り合う8方向の数字としては、B1、A2、B2の3つしか
 無く、B1-A1、A2-A1、B2-A1としても数字間差の7にはならないため
 塗りつぶしは無い。
〇塗りつぶしの例2(添付図参照)
 J5:6の場合、隣り合う8方向の数字としては、I4、J4、K4、I5、
 I6、J6、K6、K5の8つあり。I4-J5、J4-J5、K4-J5、
 I5-J5、I6-J5、J6-J5、K6-J5、K5-J5で数字間差が7となる
 K5、I6が黄色く塗り潰される。

【注意事項】
 ・使用するエクセルは2016です。
 ・数字間差で指定するのは1~99迄です。

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

投稿日時 - 2019-08-10 13:24:04

QNo.9644367

困ってます

質問者が選んだベストアンサー

参考に
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

投稿日時 - 2019-08-10 16:28:44

お礼

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

投稿日時 - 2019-08-10 16:48:10

このQ&Aは役に立ちましたか?

0人が「このQ&Aが役に立った」と投票しています

回答(2)

ANo.1

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

投稿日時 - 2019-08-10 15:28:57

補足

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

投稿日時 - 2019-08-10 16:12:17

あなたにオススメの質問