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

質問

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

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

回答No.1

kkkkkm · ベストアンサー

VBAでしたら以下でいけると思います。

Sub Test()
Dim mRng As Range

Application.ScreenUpdating = False

Range("A1:AI15").Interior.Color = xlNone
Range("A20:H230").ClearContents

For Each mRng In Range("A1:AI6")
Select Case True
Case mRng.Offset(9, 0).Value = mRng.Value * 2
Call SetData(mRng, Range("A19"))
Case mRng.Offset(9, 0).Value = mRng.Value / 2
Call SetData(mRng, Range("B19"))
Case mRng.Offset(9, 0).Value = mRng.Value + 10
Call SetData(mRng, Range("C19"))
Case mRng.Offset(9, 0).Value = mRng.Value - 10
Call SetData(mRng, Range("D19"))
Case mRng.Offset(9, 0).Value = mRng.Value + 5
Call SetData(mRng, Range("E19"))
Case mRng.Offset(9, 0).Value = mRng.Value - 5
Call SetData(mRng, Range("F19"))
Case mRng.Offset(9, 0).Value = mRng.Value + 6
Call SetData(mRng, Range("G19"))
Case mRng.Offset(9, 0).Value = mRng.Value - 6
Call SetData(mRng, Range("H19"))
Case Else
End Select
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(9, 0).Interior.Color = cRng.Interior.Color
LastRow = Cells(Rows.Count, cRng.Column).End(xlUp).Row
Cells(LastRow + 1, cRng.Column).Value = mRng.Offset(9, 0).Value
End Function

お礼

いつもお世話になっております。 早速のご回答ありがとうございます。 ＶＢＡ動かしてみて、添付図の塗潰しの漏れがあることが判りました。またよろしくお願いします。

Powered by GRATICA