Check if each worksheet contains certain color and paste into target worksheet

Question

For each worksheet in my workbook, I would like to:
- Check if rows contain cells with colour index -4142 (yellow)
- If yes, copy and paste row values into ToDo list.

I have tried:
1) For Each loop, as indicated below.
2) Dim i As Long

For i = 1 To ThisWorkbook.Worksheets.Count
Set Sh1 = Worksheets(i)

Sub Macro1()

Dim wrk As Workbook
Dim colCount As Integer
Dim ws As Worksheet
Dim Sh1 As Worksheet, Sh2 As Worksheet
Dim r As Range, r1 As Range, cell As Range
Dim iResponse As Integer
Dim LastRow As Long

iResponse = MsgBox("Do you want to COPY your 'Current List' (Hi-lighted rows) to the 'Select List' sheet?", vbYesNoCancel + vbQuestion + vbDefaultButton3, "Copy Selected Results To View In Select List")

Select Case iResponse

Case vbCancel
    MsgBox "Cancelled", vbOKOnly + vbExclamation, "Cancelled copy"

Case vbNo: 'do Nothing
    MsgBox "Doing nothing", vbOKOnly + vbInformation, "Doing nothing"

Case vbYes

For Each ws In ActiveWorkbook.Worksheets ' For each worksheet in workbook
    Set Sh1 = Worksheets(ws.Index) ' Sh1 will be first, second, etc. worksheet
    Set Sh2 = Worksheets("ToDo")  ' sheet to copy to

    Set wrk = ActiveWorkbook ' to get header as first row
    colCount = Sh1.Cells(1, 255).End(xlToLeft).Column
    With Sh2.Cells(1, 1).Resize(1, colCount)
        .Value = Sh1.Cells(1, 1).Resize(1, colCount).Value
        .Font.Bold = True
    End With

    Set r1 = Sh1.Range(Sh1.Cells(2, "D"), Sh1.Cells(Rows.Count, "C").End(xlUp))

    For Each cell In r1
        If cell.Interior.ColorIndex = 6 Then
            If r Is Nothing Then
                Set r = cell
            Else
                Set r = Union(r, cell)
            End If
        End If
    Next

    If Not r Is Nothing Then
        LastRow = Sh2.Cells(Rows.Count, "C").End(xlUp).Row
        With Sh2
            r.EntireRow.Copy Destination:=.Range("A" & LastRow + 1)
            .UsedRange.Offset(1).Interior.ColorIndex = -4142
            Range("A1").Select
        End With

    Else
        MsgBox "No info obtained", vbExclamation, "Nothing copied."

    End If

    Exit For ' Exit For loop
Next ws ' Next worksheet

End Select

End Sub

The expected output is:
If Sheet 1 has 3 rows - row 1: yellow, row 2: green, row 3: yellow
and Sheet 2 has 2 rows - row 1: yellow, row 2: blue
then ToDo sheet will show the values of Sheet 1 row 1, Sheet 1 row 3, Sheet 2 row 2

Currently the output is "No info obtained" msg.

JosephC JosephC · Accepted Answer · 2019-06-12T13:58:33

This runs through each cell in the usedrange of each worksheet. If the interior color matches it copies all the values from that row, and puts it in the ToDo list worksheet. If the row counter for the todo list hasn't changed after the loops were complete then "no info obtained" message will pop up.

Option Explicit

Sub Test()

    Dim oToDo As Worksheet
    Set oToDo = Worksheets("ToDo")
    Dim oToDoRow As Long
    oToDoRow = 2        ' Whatever row your "todo" data starts on

    Dim oCell As Range
    Dim oCurWS As Worksheet
    Dim oPrevRow As String

    For Each oCurWS In ThisWorkbook.Worksheets
        If oCurWS.Name <> "ToDo" Then
            For Each oCell In oCurWS.UsedRange
                ' I used Interior Color you should be able to use colorindex in the same way
                If oCell.Interior.Color = 65535 Then
                    If oPrevRow <> oCurWS.Index & "_" & oCell.Row Then
                        oToDo.Rows(oToDoRow).Value = oCurWS.Rows(oCell.Row).Value
                        oPrevRow = oCurWS.Index & "_" & oCell.Row
                        oToDoRow = oToDoRow + 1
                    End If
                End If
            Next
        End If
    Next

    ' Match oToDoRow with whatever is set as default at the top
    If oToDoRow = 2 Then MsgBox "No info obtained"

End Sub

Update to prevent row being listed multiple times if more than one cell in a row was highlighted.

Check if each worksheet contains certain color and paste into target worksheet

2 Answers