ネットが遅くてイライラしてない!?

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

<シート1>
   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行目以降の行ごとのデータを別シートに抽出したいと考えています。

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

A 回答 (1件)

こんばんは!



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

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
    • good
    • 0
この回答へのお礼

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

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

お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!

このQ&Aを見た人はこんなQ&Aも見ています


このQ&Aを見た人がよく見るQ&A

人気Q&Aランキング