みんなの「教えて(疑問・質問)」にみんなで「答える」Q&Aコミュニティ

こんにちはゲストさん。会員登録(無料)して質問・回答してみよう!

解決済みの質問

Excel VBA 範囲の条件付け

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

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

【下記コードで実現出来ていないこと】
1.背景色が赤いセルとそのスグ上の3行をコピペしてしまう。
2.同じシートに背景色が赤いセルが複数あっても、1つしかコピペしない。
3.sheet4のコピペ先をA3、A13、A23と仮に指定しているが、
 sheet1のコピペ内容に1行空けて、sheet2のコピペ内容、
 また1行空けて、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

投稿日時 - 2007-10-25 22:18:57

QNo.3461262

すぐに回答ほしいです

質問者が選んだベストアンサー

#1です。

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

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

   A列
01 
02 
03 タイトル行1
04 タイトル行2
05 タイトル行3
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 タイトル行4
27 タイトル行5
28 タイトル行6
29 入力15
30 赤いセル(空白以外)

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

   A列
01 
02 
03 タイトル行1
04 タイトル行2
05 タイトル行3
06 赤いセル(空白以外)
07 
08 タイトル行4
09 タイトル行5
10 タイトル行6
11 赤いセル(空白以外)

投稿日時 - 2007-10-26 08:03:25

お礼

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

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

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

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

投稿日時 - 2007-10-26 18:47:06

このQ&Aは役に立ちましたか?

0人が「このQ&Aが役に立った」と投票しています

回答(4)

ANo.3

#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

投稿日時 - 2007-10-26 01:27:57

ANo.2

#1です。

最初の質問では

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

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

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

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

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

投稿日時 - 2007-10-26 00:39:11

お礼

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

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

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

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

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

投稿日時 - 2007-10-26 07:44:00

ANo.1

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

先の質問での説明ですが下記の誤りです。
「A列を1行目から調べて、『最後に残った背景が赤いセル(ColorIndex = 3)を含む行』および、その上方の空白セルから下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

投稿日時 - 2007-10-25 23:02:32

お礼

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

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

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

助かります。

投稿日時 - 2007-10-25 23:51:38

あなたにオススメの質問