Проверьте, содержит ли каждый рабочий лист определенный цвет, и вставьте его в целевой рабочий лист

Для каждого рабочего листа в моей рабочей тетради я хотел бы:
- Проверить, есть ли в строках ячейки с цветовым индексом -4142 (желтый)
- Если да, скопируйте и вставьте значения строк в список задач.

Я пробовал:
1) Для каждой петли, как указано ниже.
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

Ожидаемый результат:
Если на листе 1 3 строки - 1-я строка: желтая, 2-я строка: зеленая, 3-я строка: желтая
и Лист 2 имеет 2 ряда - ряд 1: желтый, ряд 2: синий
то лист ToDo покажет значения Листа 1, строки 1, Листа 1, строки 3, Листа 2, строки 2.

В настоящее время выводится сообщение «Информация не получена».