[vba]Код
Option Explicit
Sub Copy()
Dim i As Long, ws1 As Worksheet, ws2 As Worksheet
On Error GoTo Err_Execute
'Start at A1
Application.ScreenUpdating = False
Set ws2 = Worksheets.Add(after:=Worksheets(Sheets.Count))
For Each ws1 In Worksheets
If ws1.Index <> Sheets.Count Then
For i = 1 To ws1.Cells(Rows.Count, "A").End(xlUp).Row
If ws1.Range("A" & i).Interior.Color = 65535 Then 'you said yellow in your example
ws1.Range("A" & i).EntireRow.Copy
ws2.Range("A" & ws2.Cells(Rows.Count, "A").End(xlUp).Row + 1).PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
End If
Next
End If
Next
ws2.Range("A1") = "Results"
Application.ScreenUpdating = True
MsgBox "The data has been successfully copied."
On Error GoTo 0
Exit Sub
Err_Execute:
MsgBox "An error occurred. Error number " & Err.Number & " - " & Err.Description
End Sub
[/vba]