セルに背景色がある行を別シートにコピー

ある一覧表があり、その中のＣ列のセルにある条件を満たしていれば背景色をつけています。
この色付セルがある行全体を別のシートに順次コピーして一覧表を作成させるマクロを以下のように作ってみました。
h = 6
For i = 7 To 最終行
If Worksheets("一覧表").Cells(i, "C").Interior.ColorIndex = 背景色番号 Then
Sheets(1).Select
Rows(i).Copy
Sheets(2).Select
h = h + 1
Rows(h).Select
ActiveSheet.Paste
End If
Next
データが少ないときはこれで問題がなかったのですが、件数が増えてきますと処理時間がかなり掛かります。４０００件のデータで３０分経っても終わりませんでした。
もっと処理時間が短くなるスマートな方法はありませんでしょうか？

No.1 ベストアンサー 回答者： merlionXX 回答日時： 2011/05/11 09:20

以下のようにSelectするのをやめ、Application.ScreenUpdating = Falseで画面の更新を一時停止するだけで飛躍的に早くなります。

　　h = 6
　　Application.ScreenUpdating = False
　　With Worksheets("一覧表")
　　　　For i = 7 To 最終行
　　　　　　If .Cells(i, "C").Interior.ColorIndex = 背景色番号 Then
　　　　　　　　h = h + 1
　　　　　　　　Sheets(1).Rows(i).Copy Sheets(2).Rows(h)
　　　　　　End If
　　　　Next i
　　End With
　　Sheets(2).Activate
　　Application.ScreenUpdating = True

もしSheets(1)とWorksheets("一覧表")が別物なら

ところでSheets(1)はWorksheets("一覧表")のことでしょうか？
そうであれば
Sheets(1).Rows(i).Copy Sheets(2).Rows(h)　は
.Rows(i).Copy Sheets(2).Rows(h)　だけでかまいません。

この回答への補足

説明不足ですいません。
Sheets(1)とWorksheets("一覧表")は同じものです。

補足日時：2011/05/11 11:47

この回答へのお礼

回答ありがとうごさいます。
教えていただいた記述で実行しますと、４０００件のデータがものの１分で終了しました。
本当に助かりました。ありがとうございました。

お礼日時：2011/05/11 11:43

No.2 回答者： KURUMITO 回答日時： 2011/05/11 09:29

シート1と同じ行に同じ色を付けるという操作のように見られますね。

それでしたらシート1の全体を選択してコピーし、シート2に書式のみを貼り付けることで良いように思いますね。

No.3 回答者： keithin 回答日時： 2011/05/11 09:57

＞Ｃ列のセルにある条件を満たしていれば背景色をつけています。

C列を「その条件」でオートフィルタを使って絞り込み，いちどにコピーしてしまいます。

with worksheets("一覧表")
.range("A6:Z" & .range("C65536").end(xlup).row).autofilter field:=3, criteria1:=">100"
.autofilter.range.copy destination:=worksheets("Sheet2").range("A6")
.autofiltermode = false
end with

この回答への補足

説明不足ですいません。ある条件というのは特定のセルで判断するのではなく、その行の複数セルを判断してということですので、目で見て地道に色を付けています。
merlionXXさんの回答で解決しました。
ありがとうございました。

補足日時：2011/05/11 11:46

No.4 回答者： shut0325 回答日時： 2011/05/11 10:00

毎回シートを切り替えずに処理すれば4000行程度なら即座に終わるかと思います。

これはmerlionXXさんが書かれているコードに変更すればよいですが、7行目から開始するのにh=6　とし　i=7～～　となっているのは間違いの元になりやすそうでちょっと怖いしスマートじゃない気がします。細かいことですが、他の人や自分でも後からコードを参照する場合に理解しづらくなりますので。

なので下記のように修正されることをお勧めします。

Const StartRow As Integer = 7:'処理開始行
Const EndRow As Integer = 最終行:'処理終了行
h = StartRow

～中略～

For i = StartRow To EndRow

～中略～
'h=h+1を削除
Sheets(1).Rows(i).Copy Sheets(2).Rows(h)
h=h+1:'こちらに移動

～以下略～

この回答へのお礼

ご指摘ありがとうございます。
できるだけ第３者が見ても理解できるものをと心がけていますが、他のところに気をとられて不親切な記述になっていました。
merlionXXさんの記述に変更を加え、無事解決しました。
ありがとうございました。

お礼日時：2011/05/11 11:39