Excel VBA 全てのセルを読み込み、背景色で判断

質問

VBA初心者です。環境はWindowsXP,Excel2003です。
よろしくお願い致します。

１～３のシートの全てのセルを読み込んで、背景色が赤色のセルの文字をシート４にコピペしたいのです。

このとき、赤色になるセルの列は必ずＦ～ＡＢまで結合されています。
替わるのは何行目かという行数のみです。

（結合セルは、最初のＨ列と見なせば良いのであれば気にしないで下さい。）

さらに、赤色のセルをコピペする際に、
赤色のセルから上に上がって、
最初の空白のあるセルの下３行も一緒にコピペして
シート４に連れて行きたいのです。

ほとんどのセルは文字と数字で埋まっていますので、
空白セルを条件にすると組み易いかと考えました。

【シート４】は下記のようになる予定です。

　ＡＢＣＤＥＦＧＨＩＪＫＬＭＮＯＰＱＲＳＴＵ
１～背景色が赤かったシート１のセル～～～～～
２～を上に行って最初の空白のあったセルの～～
３～下３行の丸々コピペ～～～～～～～～～～～
４～～背景色が赤かったシート１のセル内容～～
５～背景色が赤かったシート２のセル～～～～～
６～を上に行って最初の空白のあったセルの～～
７～下３行の丸々コピペ～～～～～～～～～～～
８～～背景色が赤かったシート２のセル内容～～
９～背景色が赤かったシート１のセル～～～～～
10～を上に行って最初の空白のあったセルの～～
11～下３行の丸々コピペ～～～～～～～～～～～
12～～背景色が赤かったシート１のセル内容～～

カナリの初心者なため、組まれたものは読めるのですが、
最初から組む事がなかなか出来ません。

お手数をおかけしますが、
どなたか分かる方がいらっしゃったらお願い致します。

回答No.1

papayuka · ベストアンサー

カナリの初心者は普通、組まれたものも読めませんよ。

全てのセルって 16777216個もあります。
たぶん一個ずつ色を調べるって話では無いと思いますが、条件があまりに不透明です。
参考程度にサンプルを書きましたので、希望に近いようなら修正してお使い下さい。

A列を1行目から調べて、最初に見つけた背景が赤いセル（ColorIndex = 3）を含む行、および、その上方の空白セルから下３行をコピー状態にします。

Sub Test()
Dim i As Long, r As Range

With Worksheets("Sheet1")
　　For i = 1 To .Range("A65536").End(xlUp).Row
　　　　If .Range("A" & i).Interior.ColorIndex = 3 Then
　　　　　 Set r = .Range("A" & i).EntireRow
　　　　　 Set r = Union(r, r.End(xlUp).Resize(3).EntireRow)
　　　　End If
　　Next i
End With

If Not r Is Nothing Then r.Copy

End Sub

お礼

非常に助かりました。
ありがとうございましたm( _ _ )m

補足

助かります。ありがとうございます。

質問なのですが、
＞A列を1行目から調べて、最初に見つけた背景が赤いセル（ColorIndex = 3）を含む行、および、その上方の空白セルから下３行をコピー状態にします。

【質問１】
最初に見つけた背景が赤いセルだけでなく、
背景が赤いセルに関しては、同じように対象としたいのですが、
どのようにすれば宜しいでしょうか。

【質問２】
＞A列を1行目から調べて、最初に見つけた背景が赤いセル
＞（ColorIndex = 3）を含む行、および、その上方の空白セルから
＞下３行をコピー状態にします。

これを

A列を1行目から調べて、見つけた背景が赤いセル（全て）をコピーし、
その際、その上方の空白セルから下３行（背景が赤いセルは含まない）もコピー状態にする。

としたいのですが、どのようにすれば宜しいでしょうか。

背景色が赤いセルとあわせてコピペしたいのはタイトル行となっている
３行で、背景色が赤いセルのかなり上方にあるため、このようにしています。

よろしくお願い致します。