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

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.

Answer 1

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.

Answer 2

Do you need whole row to be "yellow" ? or there is allways one cell in each row ?.
I'm asking what if A1 is yellow ,B1 is blue, C1 is red, D1 is yellow you want to copy from this row only A1 and D1 to Sheet "ToDo"- into A1 and B1 or copy/paste entire row?
Have a great day