消去数字の該当数字を消去して縦に重複数字塗潰す。

質問

このカテゴリーのエクセルの達人の方々に質問です。
どなたか回答して頂ける方がおみえでしたらよろしくお願いします。
（ちゃんとした回答ではなく、文句やクレーム等を混ぜた記載はご遠慮ください。
　私の質問が気に入らない場合は無視して頂ければ結構です。）
【質問】
添付図のとおり、A1～AI6の6行×35列の中に数字が重複して入っています。
また、消去数字がAM1～BD1に入っています。
消去数字に該当する数字が検索対象のA1～AI6の中にあれば、
数字を消去した後、縦（A列～AI列）に重複数字の有無をチェックして
該当あれば塗り潰す方法が知りたいです。

【注意事項】
　　・重複数字の塗潰しの色は以下のとおりです。
　　　　２個重複：黄色、３個重複：青色　４個重複：赤色
　　　＊添付図には赤色になるケースはありません。
　　・消去数字と検索対象の数字は毎回異なります。
　　・実現方法は、ＶＢＡでもその他方法でもかまいません。
　　・使用するエクセルは２０２１です。

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

回答No.6

kkkkkm · ベストアンサー

> 消去数字がAM1～BD1に入っています

これを見逃してまして画像でAX1までデータがあったのでAX1までとしてましたが式やVBAでのAX1をBD1に変更してください。

お礼

いつもお世話になっております。 短時間でたくさんの回答ありがとうございます。５つ目と６つ目の回答を合わせて実行したところ、上手くやりたい結果になりました。ありがとうございます。

Powered by GRATICA

回答No.7

kkkkkm

テストの時にはそこまで考えてないので入れてませんでしたが
もし表示がもたつくようでしたら
Application.ScreenUpdatingを以下のように入れてみてください。

Sub TestColor()
Dim mRng As Range
Dim index As Variant
Dim cnt As Long

Application.ScreenUpdating = False

中略

Application.ScreenUpdating = True
End Sub

回答No.5

kkkkkm

色付けもVBAでする場合です。

Sub TestColor()
Dim mRng As Range
Dim index As Variant
Dim cnt As Long

Range("A1:AI6").Interior.ColorIndex = xlNone

For Each mRng In Range("A1:AI6")
index = Application.Match(mRng.Value, Range("AM1:AX1"), 0)
If Not IsError(index) Then
mRng.ClearContents
Else
cnt = WorksheetFunction.CountIf(Range(Cells(1, mRng.Column), Cells(6, mRng.Column)), mRng.Value)
Select Case cnt
Case 2
mRng.Interior.Color = vbYellow
Case 3
mRng.Interior.Color = vbCyan
Case 4
mRng.Interior.Color = vbRed
Case Else

End Select
End If
Next
End Sub

回答No.4

kkkkkm

何度もすみません、あとから思いつくもので

もし値を消さなくて見えなくすればいいだけでしたらVBAなしで

条件つき書式の
一番上に
数式で
=COUNTIF($AM$1:$AX$1,A1)<>0
フォントの色を白にして
条件を満たす場合は停止
とすれば一応見えなくなります。

回答No.1で黄色青赤などの色付けを条件付き書式で回答しましたが、もし色付けもVBAでという場合はコードを追加しますので。

回答No.3

kkkkkm

回答No.1のVBAで変更したほうが分かりやすいかなと思える部分があったので
回答No.2のいらない部分を削除したものと一部変更したものをこちらに記載しますのでこちらで試してみてください。

Sub Test()
Dim mRng As Range
Dim index As Variant

For Each mRng In Range("A1:AI6")
index = Application.Match(mRng.Value, Range("AM1:AX1"), 0)
If Not IsError(index) Then
mRng.ClearContents
End If
Next
End Sub

回答No.2

kkkkkm

回答No.1の訂正です。
VBAコードの中の
Debug.Print IsError(index)
はいらないので削除しておいてください。

回答No.1

kkkkkm

条件つき書式の数式でを利用して以下の3個の条件付き書式を設定してください。
A1からAI6まで選択した状態で

=COUNTIF(A$1:A$6,A1)=2
で黄色
=COUNTIF(A$1:A$6,A1)=3
で青
=COUNTIF(A$1:A$6,A1)=4
で赤

削除はVBAで以下のコードで試してみてください。

Sub Test()
Dim mRng As Range
Dim index As Variant

For Each mRng In Range("A1:AI6")
index = Application.Match(mRng.Value, Range("AM1:AX1"), 0)
Debug.Print IsError(index)
If IsError(index) = False Then
mRng.ClearContents
End If
Next
End Sub