複数シートの色付きセルがある行を別シートに抽出

複数シートの各E列に色付きセルがある行のみ、１つの別シートに
抽出したいと考えています。
セルの色は条件付書式で付けています。
なお、複数シートの項目はすべて同一で、１行目は項目名が入っています。
特に複数シートが対象になっているために過去ログから中々近いものが見当たりません。
どなたかヒントだけでも頂ければ幸いです。

No.2 ベストアンサー 回答者： kuma3f 回答日時： 2008/03/19 21:02

ANo.1のkuma3fです。

繰り返し使用される場合は、抽出シートのクリアは必要ですね。

項目行を１行のみとする場合は、次のようにされたらよいと思います。

Dim シート As Worksheet
Dim シート名 As String
Dim 行番号 As Long
Dim 抽出行番号 As Long
Dim 最大行 As Long
Dim スイッチ As Integer

Sheets("抽出シート").Cells.ClearContents
Application.ScreenUpdating = False
抽出行番号 = 1
スイッチ = 0

For Each シート In ThisWorkbook.Sheets
シート.Activate
シート名 = ActiveWorkbook.ActiveSheet.Name
最大行 = Application.WorksheetFunction.CountA(Worksheets(シート名).Range("E1:E65536"))

If シート名 <> "抽出シート" Then

If スイッチ = 0 Then '最初のシートのみ項目行を抽出
Sheets(シート名).Rows(1).Select
Selection.Copy
Sheets("抽出シート").Select
Sheets("抽出シート").Rows(抽出行番号).Select
ActiveSheet.Paste
Application.CutCopyMode = False
抽出行番号 = 抽出行番号 + 1
スイッチ = 1
End If
行番号 = 2 '２行目から抽出対象

Do
Sheets(シート名).Select
Sheets(シート名).Cells(行番号, 5).Select
'***** 条件で抽出 *****
If Sheets(シート名).Cells(行番号, 5) > 100 Then
Sheets(シート名).Rows(行番号).Select
Selection.Copy
Sheets("抽出シート").Select
Sheets("抽出シート").Rows(抽出行番号).Select
ActiveSheet.Paste
Application.CutCopyMode = False
抽出行番号 = 抽出行番号 + 1
End If
'**********************
行番号 = 行番号 + 1
Loop Until 行番号 > 最大行
End If
Next シート

Sheets("抽出シート").Select
Sheets("抽出シート").Range("A1").Select
Application.ScreenUpdating = True
MsgBox "抽出しました。"

例は、スイッチで最初のシートの項目行のみ抽出させています。
条件での抽出は２行目からにしています。

この回答へのお礼

kuma3f様

またまたありがとうございました。
まさに希望通りの結果を得ることができました。
これは色々と発展もできそうですね。
本当にありがとうございました。

お礼日時：2008/03/21 11:43

No.1 回答者： kuma3f 回答日時： 2008/03/09 15:19

条件付き書式で色がついているセルを関数やマクロで判断するのは難しいようです。

条件付き書式の条件で抽出されてはいかがでしょうか。

参考までに
例えば「Ｅ列のセルの値が１００より大きい」で色をつけている場合は、次のようにします。

メニューバーの「挿入」→「ワークシート」で新たなシートを作成してシート名を"抽出シート"にする
　↓
メニューバーの「ツール」→「マクロ」→「マクロ」をクリック
　↓
マクロのダイアログが表示されたらマクロ名に自由に名前を入力してください。（例：抽出）
　↓
名前を入力しましたら、「作成」をクリック
　↓
Microsoft Visual Basicの画面が開きますのでSub 抽出()の下に次のコードをコピーして貼り付けてください。

Dim シート As Worksheet
Dim シート名 As String
Dim 行番号 As Long
Dim 抽出行番号 As Long
Dim 最大行 As Long

Application.ScreenUpdating = False
抽出行番号 = 1

For Each シート In ThisWorkbook.Sheets
シート.Activate
シート名 = ActiveWorkbook.ActiveSheet.Name
最大行 = Application.WorksheetFunction.CountA(Worksheets(シート名).Range("E1:E65536"))
行番号 = 1
If シート名 <> "抽出シート" Then
Do
Sheets(シート名).Select
Sheets(シート名).Cells(行番号, 5).Select
'***** 条件で抽出 *****
If Sheets(シート名).Cells(行番号, 5) > 100 Then'100より大きいなら抽出
Sheets(シート名).Rows(行番号).Select
Selection.Copy
Sheets("抽出シート").Select
Sheets("抽出シート").Rows(抽出行番号).Select
ActiveSheet.Paste
Application.CutCopyMode = False
抽出行番号 = 抽出行番号 + 1
End If
'**********************
行番号 = 行番号 + 1
Loop Until 行番号 > 最大行
End If
Next シート

Sheets("抽出シート").Select
Sheets("抽出シート").Range("A1").Select
Application.ScreenUpdating = True
MsgBox "抽出しました。"

'****コピー貼り付けはここまで ****

Microsoft Visual Basicの画面を×で閉じます
　↓
Excel画面のメニューバーの「ツール」→「マクロ」→「マクロ」をクリック
　↓
先ほど名前を付けたマクロを選択して「実行」をクリック
　↓
"抽出シート"のＡ列に抽出されます。

例は、どのシートもＥ列の条件付き書式の条件が同じでデータの最終行までに空白行（抜けた行）が無いことが前提です。

この回答への補足

kuma3f様
大変丁寧にご説明いただきましてありがとうございます。
海外出張によりネットがつなげない環境だったため
ご返信が遅くなり申し訳ありませんでした。

早速試してみました。
これは今後、検索対象のシートが増えてもそのまま使えるのですね。
すごく便利です。

私は、検索対象シートごとにCase 1、Case 2　と書いていくしかないのかと考えていました。

For i=1 to n '検索シート数
　　Select Case i
Case 1 :
Case 2 :
・・・・・
　　End Select
'共通処理
　Next

従って検索対象のシートが増えるたびにコードを
追加する必要があると思っていました。

なお、抽出の際に前の結果をクリアするために
宣言文のあとに下記を加えてみました。

Sheets("抽出シート").Cells.ClearContents

ところで、各検索対象シートの１行目は共通の項目名が
入っていますが、抽出結果はすべてのシートから
各々１行目の項目を引っ張ってきてしまいます。
項目行は1行目の1行のみ、とはできませんでしょうか？

ご教示頂ければ幸いです。

補足日時：2008/03/19 12:57