複数シートに色付きセル(条件つき書式で設定済み）の行を別シートに抽出

初めまして。
シート数は30程度。
列数は同じで行数はシートごと（最大30行)に異なります。
複数シートの期限には条件式書式で(期限切れは赤、期限切れ30日前は黄色）セルに色がついています。(期限切れ判断の日はTODAYを使用しています）

＜シート１＞
　　　A　　　　　B　　　　　　C　　　　　D　　　　　E　
1　○○○株式会社
2　　車番　　　車検期限　　保険期限　　　運転者名　　免許期限
3　東京100　　2021/1/1　2020/10/10　　あいうえ　　2020/12/12
4　千葉200　　2019/1/1　2019/1/1　　　かきくけ　　2020/8/8
5　　・　　　　　・　　　　　・　　　　　　　・　　　　・
6　　・　　　　　・　　　　　・　　　　　　　・　　　　・
．
．
30

＜シート2＞
　　　A　　　　　B　　　　　　C　　　　　D　　　　　E　
1　△△△株式会社
2　　車番　　　車検期限　　保険期限　　　運転者名　　免許期限
3　千葉200　　2019/2/1　2019/2/1　　　さしすせ　　2020/9/9
4　千葉200　　2021/1/1　2021/1/1　　　たちつて　　2020/8/8
5　　・　　　　　・　　　　　・　　　　　　　・　　　　・
6　　・　　　　　・　　　　　・　　　　　　　・　　　　・
．
．
30

　　　　　　　　　　　　　↓
＜抽出シート＞
　　　A　　　　　B　　　　　　C　　　　　D　　　　　E　
1　○○○株式会社
2　　車番　　　車検期限　　保険期限　　　運転者名　　免許期限
3　千葉200　　2019/1/1　 2019/1/1　　 かきくけ　　2020/8/8
4
5　△△△株式会社
6　　車番　　　車検期限　　保険期限　　　運転者名　　免許期限
7　千葉200　　2019/2/1　2019/2/1　　　さしすせ　　2020/9/9
8　
9

vbaを使用して
セルに色がついているシートの
1行目　会社名
2行目以降の行ごとのデータを別シートに抽出したいと考えています。

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

No.1 ベストアンサー 回答者： tom04 回答日時： 2020/07/31 23:48

こんばんは！

一例です。
標準モジュールにしてください。

Sub Sample1()
　Dim i As Long, j As Long, k As Long
　Dim wS As Worksheet
　Dim myFlg1 As Boolean, myFlg2 As Boolean

　　Application.ScreenUpdating = False
　　　With Worksheets("抽出シート")
　　　　'//▼「抽出シート」のデータを一旦消去//
　　　　.Range("A:E").ClearContents
　　　　.Range("B:C,E:E").NumberFormatLocal = "yyyy/m/d"

　　　　'//▼ココから操作//
　　　　For k = 1 To Worksheets.Count
　　　　　If Worksheets(k).Name <> .Name Then
　　　　　　Set wS = Worksheets(k)
　　　　　　　For i = 2 To wS.Cells(Rows.Count, "A").End(xlUp).Row
　　　　　　　　For j = 2 To 5 '//←B～E列まで//
　　　　　　　　　If wS.Cells(i, j).DisplayFormat.Interior.ColorIndex = 3 Or _
　　　　　　　　　　wS.Cells(i, j).DisplayFormat.Interior.ColorIndex = 6 Then
　　　　　　　　　　　myFlg2 = True
　　　　　　　　　　　Exit For
　　　　　　　　　End If
　　　　　　　　Next j
　　　　　　　　　If myFlg2 = True Then
　　　　　　　　　　If myFlg1 = False Then
　　　　　　　　　　　.Cells(Rows.Count, "A").End(xlUp).Offset(2).Resize(2, 5).Value = wS.Range("A1").Resize(2, 5).Value
　　　　　　　　　　　myFlg1 = True
　　　　　　　　　　End If
　　　　　　　　　　　.Cells(Rows.Count, "A").End(xlUp).Offset(1).Resize(, 5).Value = wS.Cells(i, "A").Resize(, 5).Value
　　　　　　　　　End If
　　　　　　　　　　myFlg2 = False
　　　　　　　Next i
　　　　　End If
　　　　　　myFlg1 = False
　　　　Next k
　　　　　.Range("A1:E2").Delete shift:=xlUp
　　　　　.Columns.AutoFit
　　　　　.Activate
　　　End With
　　Application.ScreenUpdating = True
　　　MsgBox "完了"
End Sub

※　セルの塗りつぶしの色番号が異なると何も反応しません。
カラーインデックスの番号は
赤　→　3
黄　→　6
としています。m(_ _)m

この回答へのお礼

早速のご回答ありがとうございました。
希望通りにできました。

お礼日時：2020/08/01 13:13