黄色と同じ位置を赤色で塗潰しをして数字を抽出する

質問

このカテゴリーのエクセルの達人の方々に質問です。
どなたか回答して頂ける方がおみえでしたらよろしくお願いします。
（ちゃんとした回答ではなく、文句やクレーム等を混ぜた記載はご
　遠慮ください。私の質問が気に入らない場合は無視して頂ければ
　結構です。）
【質問】
　添付図のとおり、「①無作為に数字を黄色で塗潰し」として、
　Ａ１～Ｙ４迄の数字に無作為に手で黄色で数字を塗潰し、
「➁黄色と同じ位置を赤色で塗潰し」として、
　Ａ９～Ｙ１２までの数字の中で、黄色と同じ位置にある数字を
赤色で塗潰し、「③赤色で塗潰しの数字を並べる」で、
　➁で赤色で塗潰された数字をＣ１５～下に並べる方法が知りたい
　です。

　ＶＢＡでもその他方法でも構いません。
【注意事項】
　・「①無作為に数字を黄色で塗潰し」に入る数字は重複ありで、
　　空白はありません。毎回、手で黄色で塗潰す位置や個数は変わ
　　ります。
　・「➁黄色と同じ位置を赤色で塗潰し」に入る数字も重複ありで、
　　空白はありません。毎回、黄色の位置が変われば赤色の位置も
　　変わります。
　・「③赤色で塗潰しの数字を並べる」は、➁で赤色で塗潰された
　　数字をそのままＣ１５～下に並べます。
　・「①無作為に数字を黄色で塗潰し」、
　　「➁黄色と同じ位置を赤色で塗潰し」、　　　　　
　　「③赤色で塗潰しの数字を並べる」は、
　　　説明のためにつけているだけです。
　・使用するエクセルは２０２１です。

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

回答No.1

kkkkkm · ベストアンサー

以下で試してみてください。

65535は実際にマクロの記録で黄色で色付けしたコードを見てその値を指定してください。

Sub Test()
Dim i As Long, j As Long, k As Long

k = 15
For i = 1 To 4
For j = 1 To Columns("Y").Column
If Cells(i, j).Interior.Color = 65535 Then
Cells(i, j).Offset(8, 0).Interior.Color = vbRed
Cells(k, "C").Value = Cells(i, j).Offset(8, 0).Value
k = k + 1
End If
Next
Next

End Sub

Foe Each を使うと右と下どちらに探していくか決定してないという事をかなり以前に言われた(下に先に言った記憶はありませんが)ので順番が1行目から4行目とならなければいけない場合は上のコードで
方向は気にしない場合でしたら下記の方がすっきりしてるかもしれません。

Sub Test2()
Dim mRng As Range
Dim k As Long

k = 15
For Each mRng In Range("A1:Y4")
If mRng.Interior.Color = 65535 Then
mRng.Offset(8, 0).Interior.Color = vbRed
Cells(k, "C").Value = mRng.Offset(8, 0).Value
k = k + 1
End If
Next

End Sub

お礼

早速のご回答ありがとうございます。 今回は赤色で塗潰しがされてその数字が抽出できればよいので方向は気にしてません。 なので、下の方法を使わさせていただきます。

Powered by GRATICA