Sub InfoRatio()

​

Dim thisRow As Long

Dim lastRow As Long

Dim lastSheet As Long

Dim destinationRow As Long

Dim i As Integer

​

destinationRow = 1

​

lastSheet = ThisWorkbook.Worksheets.Count

​

​

For i = 1 To ThisWorkbook.Worksheets.Count - 1

​

lastRow = Sheets(i).Cells(Rows.Count, "A").End(xlUp).Row

​

For thisRow = 1 To lastRow

​

If Sheets(i).Cells(thisRow, 1).DisplayFormat.Interior.Color = 65535 Then

Sheets(lastSheet).Rows(destinationRow).Value = Sheets(i).Rows(thisRow).Value

destinationRow = destinationRow + 1

End If

​

Next thisRow

​

Next i

​

End Sub