比較元と先の数字がルールに合えば塗潰して出力する２

質問

このカテゴリーのエクセルの達人の方々に質問です。
どなたか回答して頂ける方がおみえでしたらよろしくお願いします。
（ちゃんとした回答ではなく、文句やクレーム等を混ぜた記載はご
　遠慮ください。私の質問が気に入らない場合は無視して頂ければ
　結構です。）
【質問】
　添付図のとおり、①比較元と➁比較先で同じ位置にあるセルの数字が
　以下のルールに合えばお互いのセルを指定の色で塗潰し、
　➁比較先の数字の下（１８行目～）に➁比較先側の数字を縦に並べる方法が
　知りたいです。
　　◎ルール
　　　１）①比較元の数字と➁比較先の数字が一致する場合は
　　　　　　両方のセルを黄色に塗り潰す。
　　　２）①比較元の数字に＋１にした数字が➁比較先の数字と
　　　　　　一致する場合は両方のセルを青色に塗り潰す。
　　　３）①比較元の数字にー１した数字が➁比較先の数字と
　　　　　　一致する場合は両方のセルを青色に塗り潰す。
　　　４）①比較元の数字に×２した数字が➁比較先の数字と
　　　　　　一致する場合は両方のセルを橙色に塗り潰す。
　　　５）①比較元の数字に÷２した数字が➁比較先の数字と
　　　　　　一致する場合は両方のセルを橙色に塗り潰す。
　　　６）①比較元の数字に＋１０した数字が➁比較先の数字と
　　　　　　一致する場合は両方のセルを赤色に塗り潰す。
　　　７）①比較元の数字にー１０した数字が➁比較先の数字と
　　　　　　一致する場合は両方のセルを赤色に塗り潰す。
　　　８）①比較元の数字に＋５した数字が➁比較先の数字と
　　　　　　一致する場合は両方のセルを緑色に塗り潰す。
　　　９）①比較元の数字にー５した数字が➁比較先の数字と
　　　　　　一致する場合は両方のセルを緑色に塗り潰す。
【注意事項】
　・「①比較元」、「➁比較先」は５セル×５セルで４つあります。
　・「③結果表示」も「➁比較先」の下にそれぞれあります。
　・「①比較元」、「➁比較先」に入る数字は重複ありで、
　　空白はありません。
　・「①比較元」、「➁比較先」、「③結果表示」は、
　　　説明のためにつけているだけです。
　・９つあるルールのうち、複数のルールに該当する数字がある
　　場合、最初に該当するルールの色で塗潰してください。　　　　
　・使用するエクセルは２０２１です。

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

回答No.1

kkkkkm · ベストアンサー

前回のコードを一部変更したものです。

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

Application.ScreenUpdating = False

Range("A1:AI13").Interior.Color = xlNone
Range("A18:AM230").ClearContents

For i = 0 To 30 Step 10
For Each mRng In Range("A1:E5").Offset(0, i)
Select Case True
Case mRng.Offset(8, 0).Value = mRng.Value
Call SetData(mRng, Range("A17").Offset(0, i))
Case mRng.Offset(8, 0).Value = mRng.Value + 1
Call SetData(mRng, Range("B17").Offset(0, i))
Case mRng.Offset(8, 0).Value = mRng.Value - 1
Call SetData(mRng, Range("C17").Offset(0, i))
Case mRng.Offset(8, 0).Value = mRng.Value * 2
Call SetData(mRng, Range("D17").Offset(0, i))
Case mRng.Offset(8, 0).Value = mRng.Value / 2
Call SetData(mRng, Range("E17").Offset(0, i))
Case mRng.Offset(8, 0).Value = mRng.Value + 10
Call SetData(mRng, Range("F17").Offset(0, i))
Case mRng.Offset(8, 0).Value = mRng.Value - 10
Call SetData(mRng, Range("G17").Offset(0, i))
Case mRng.Offset(8, 0).Value = mRng.Value + 5
Call SetData(mRng, Range("H17").Offset(0, i))
Case mRng.Offset(8, 0).Value = mRng.Value - 5
Call SetData(mRng, Range("I17").Offset(0, i))
Case Else
End Select
Next
Next
Application.ScreenUpdating = True

End Sub

Function SetData(mRng As Range, cRng As Range)
Dim LastRow As Long
mRng.Interior.Color = cRng.Interior.Color
mRng.Offset(8, 0).Interior.Color = cRng.Interior.Color
LastRow = Cells(Rows.Count, cRng.Column).End(xlUp).Row
Cells(LastRow + 1, cRng.Column).Value = mRng.Offset(8, 0).Value
End Function

お礼

いつもお世話になっております。 また早速のご回答ありがとうございます。 今回も一部、塗潰しサンプルが誤っていることに気づけました。 またよろしくお願いいたします。

Powered by GRATICA