Excel VBA 範囲の条件付け

質問

現在下記のコードを組んでいます。

やりたい事は、sheet１～３で背景色の赤いセルと、
そのセルの上方の最初の空白セルの下３行をsheet4にコピペする。

【下記コードで実現出来ていないこと】
１．背景色が赤いセルとそのスグ上の３行をコピペしてしまう。
２．同じシートに背景色が赤いセルが複数あっても、１つしかコピペしない。
３．sheet4のコピペ先をA3、A13、A23と仮に指定しているが、
　sheet1のコピペ内容に１行空けて、sheet2のコピペ内容、
　また１行空けて、sheet3のコピペ内容というセル指定にしたい。

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

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

Sheets("Sheet4").Select
Range("A3").Select
ActiveSheet.Paste

With Worksheets("sheet2")
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

Sheets("Sheet4").Select
Range("A13").Select
ActiveSheet.Paste

With Worksheets("Sheet3")
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

Sheets("sheet4").Select
Range("A23").Select
ActiveSheet.Paste

End Sub

回答No.4

papayuka · ベストアンサー

#1です。

> 具体的な環境は、
> A20が背景色が赤色で、その上に上がった最初の空白のセルが
> A2であったりします。その下の３行とはA3,A4,A5なわけです。
>
> 同じシート上で、背景色が赤色のセルがA30にあって、
> その上に上がった最初の空白セルA25であることもあります。
> その下の３行はA26,A27,A28です。

これなら #1 で動くと思うのですが、、、
Sheet1が下記の場合

　　　A列
01　
02　
03　タイトル行１
04　タイトル行２
05　タイトル行３
06　入力1
07　入力2
08　入力3
09　入力4
10　入力5
11　入力6
12　入力7
13　入力8
14　入力9
15　入力10
16　入力11
17　入力12
18　入力13
19　入力14
20　赤いセル（空白以外）
21　
22　
23　
24　
25　
26　タイトル行４
27　タイトル行５
28　タイトル行６
29　入力15
30　赤いセル（空白以外）

Sheet4 はこうなりましたけど、、、

　　　A列
01　
02　
03　タイトル行１
04　タイトル行２
05　タイトル行３
06　赤いセル（空白以外）
07　
08　タイトル行４
09　タイトル行５
10　タイトル行６
11　赤いセル（空白以外）

お礼

本当に色々と考えてくださって、ありがとうございました。

上記の内容を書いてみて、キレイにマクロが動きました。

私の持っている元データのセルに何らかの
設定がされているようで、そちらでは動かないのですが、
それは別問題です。自分で調べてみます。

ありがとうございました！

回答No.3

papayuka

#1です。

まだ違うかも知れませんけど、参考に。

Sub Test1()
Dim i As Long, r As Range, myArray
myArray = Array("Sheet1", "Sheet2", "Sheet3")
For cnt = 0 To 2
With Worksheets(myArray(cnt))
　　For i = 1 To .Range("A65536").End(xlUp).Row
　　　　If .Range("A" & i).Interior.ColorIndex = 3 Then
　　　　　 If r Is Nothing Then
　　　　　　　Set r = .Range("A" & i).EntireRow
　　　　　 Else
　　　　　　　Set r = Union(r, .Range("A" & i).EntireRow)
　　　　　 End If
　　　　End If
　　Next i
　　If Not r Is Nothing Then
　　　 Set r = Union(r, r.End(xlUp).Resize(3).EntireRow)
　　　 r.Copy Destination:=Worksheets("Sheet4"). _
　　　　　　 Range("A65536").End(xlUp).Offset(2, 0).EntireRow
　　　 Set r = Nothing
　　End If
End With
Next cnt

End Sub

回答No.2

papayuka

#1です。

最初の質問では

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

とあり、「赤色セルを見つけた場合は上に必ず空白セルがあり、その空白セルの下３行もコピーしたい」と認識しています。

> 背景色が赤いセルとそのスグ上の３行をコピペしてしまう。

これに該当するのは「最初の赤色セルが A4 で A1～A3 に空白は無い」とか「A11が赤色セルでA7が空白セル」のような場合だと思います。

回答者はシートの構成が見れない（理解出来てない）ので、想像だけで書いています。
まる投げで完全な回答を求められても、シートの構成も解らない状態では何が悪いのかも解りませんし、質問の意図もつかめません。
ご自分の環境に合わせて修正するくらいは必要かと思いますよ。

お礼

回答者はシートの構成が見れない（理解出来てない）ので、想像だけで書いています。

すみません、おっしゃる通りです。

具体的な環境は、
A20が背景色が赤色で、その上に上がった最初の空白のセルが
A2であったりします。その下の３行とはA3,A4,A5なわけです。

同じシート上で、背景色が赤色のセルがA30にあって、
その上に上がった最初の空白セルA25であることもあります。
その下の３行はA26,A27,A28です。

なのでそのような表現になっています。

回答No.1

papayuka

前の質問で補足に答える前に閉じられたので、ここに書きます。
http://okwave.jp/qa3452416.html

先の質問での説明ですが下記の誤りです。
「A列を1行目から調べて、『最後に残った背景が赤いセル（ColorIndex = 3）を含む行』および、その上方の空白セルから下３行がコピー状態になります」
ループさせているので途中行も判定してます。
従ってコピーしている部分のコード位置をループ内に変えて、コピー後に変数　r　をいったんリセットすれば希望動作に近いと思います。

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
　　　　If Not r Is Nothing Then
　　　　　 r.Copy Destination:=Worksheets("Sheet4"). _
　　　　　　 Range("A65536").End(xlUp).Offset(2, 0).EntireRow
　　　　　 Set r = Nothing
　　　　End If
　　Next i
End With

End Sub

お礼

ありがとうございますm( _ _ )m

後は、最初にも書かせて頂きました通り、
【下記コードで実現出来ていないこと】
１．背景色が赤いセルとそのスグ上の３行をコピペしてしまう。

が解決できれば完璧です。

助かります。