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

質問

このカテゴリーのエクセルの達人の方々に質問です。
どなたか回答して頂ける方がおみえでしたらよろしくお願いします。
（ちゃんとした回答ではなく、文句やクレーム等を混ぜた記載はご
　遠慮ください。私の質問が気に入らない場合は無視して頂ければ
　結構です。）
【質問】
2024/06/16に「黄色と同じ位置を赤色で塗潰しをして数字を抽出
する」の質問をさせて頂きましたが、その時の質問の２つ目です。

添付図のとおり、「①前回数字を手動で黄色で塗潰し」として、
a、b、c、dの枠内の数字に無作為に手動で黄色で数字を塗潰し、
「➁黄色と同じ位置を赤色で自動で塗潰す」として、
Ａ，Ｂ、Ｃ，Ｄの枠内の数字の中で、黄色と同じ位置にある数字を
赤色で塗潰し、「③１数字毎に①⇒➁の塗潰し数字を下へ羅列する」で、➁で赤色で塗潰された数字をＡ，Ｂ、Ｃ，Ｄのそれぞれの枠の下に１数字毎に下に羅列します。

実現方法はＶＢＡでもその他方法でも構いません。
【注意事項】
　・「①前回数字を手動で黄色で塗潰し」に入る数字は重複ありで、
　　空白はありません。毎回、手動で黄色で塗潰す位置や個数は変わ
　　ります。
　・「➁黄色と同じ位置を赤色で自動で塗潰す」に入る数字も重複
　　ありで、空白はありません。毎回、黄色の位置が変われば赤色
　　の位置も自動で変わります。
　・「③１数字毎に①⇒➁の塗潰し数字を下へ羅列する」は、
　　　①⇒➁で黄色から赤色で塗潰された数字を１つずつ枠の下へ
　　　羅列します。
　・使用するエクセルは２０２１です。

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

回答No.4

kkkkkm · ベストアンサー

最後のエリアが3行ですがこのエリアの4、5行に黄色を塗ることはないと考えていますので最後のエリアも5行分検索しています。
3行分にしたほうがいいという事でしたら以下で試してみてください。

Sub Test2()
Dim mRng As Range
Dim mRow As Long, mCol As Long, n As Long, LRow As Long

mCol = 0
LRow = 5

For n = 1 To Columns("AE").Column Step 8
mRow = 16
If n >= Columns("Y").Column Then
LRow = 3
End If
For Each mRng In Range("A1:G" & LRow).Offset(0, mCol)
If mRng.Interior.Color = 65535 Then
mRng.Offset(8, 0).Interior.Color = vbRed
Cells(mRow, "A").Offset(0, mCol).Value = mRng.Value
Cells(mRow, "B").Offset(0, mCol).Value = "⇒"
Cells(mRow, "C").Offset(0, mCol).Value = mRng.Offset(8, 0).Value
mRow = mRow + 1
End If
Next
mCol = mCol + 8
Next
End Sub

お礼

いつもお世話になっております。 今年もよろしくお願いします。 このやり方で上手くいきました。 ありがとうございます。

Powered by GRATICA

回答No.3

kkkkkm

5行になってたのを見逃してました
Test1の
For i = 1 To 4
4を5に
Test2は
Range("A1:G4").
G4をG5に
変更してください。

回答No.2

kkkkkm

前回の質問を確認したら以下のパターンで利用してたんですね。
前回利用したパターンと同じパターンでしたら以下で試してみてください。

Sub Test2()
Dim mRng As Range
Dim mRow As Long, mCol As Long, n As Long

For n = 1 To Columns("AE").Column Step 8
mRow = 16
For Each mRng In Range("A1:G4").Offset(0, mCol)
If mRng.Interior.Color = 65535 Then
mRng.Offset(8, 0).Interior.Color = vbRed
Cells(mRow, "A").Offset(0, mCol).Value = mRng.Value
Cells(mRow, "B").Offset(0, mCol).Value = "⇒"
Cells(mRow, "C").Offset(0, mCol).Value = mRng.Offset(8, 0).Value
mRow = mRow + 1
End If
Next
mCol = mCol + 8
Next
End Sub

回答No.1

kkkkkm

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

Sub Test()
Dim i As Long, j As Long, n As Long
Dim mRow As Long, mCol As Long

mCol = 0

For n = 1 To Columns("AE").Column Step 8
mRow = 16
For i = 1 To 4
For j = n To 6 + n
If Cells(i, j).Interior.Color = 65535 Then
Cells(i, j).Offset(8, 0).Interior.Color = vbRed
Cells(mRow, "A").Offset(0, mCol).Value = Cells(i, j).Value
Cells(mRow, "B").Offset(0, mCol).Value = "⇒"
Cells(mRow, "C").Offset(0, mCol).Value = Cells(i, j).Offset(8, 0).Value
mRow = mRow + 1
End If
Next
Next
mCol = mCol + 8
Next

End Sub