copy data based on highlighted items

hello

I  have  a problem  with running speed for  this  code ,despite  of  the  data  are  small  not  huge . I tested  and  gives 0.4 !!!  .the  code  copy  data across all  of  the  sheets  based on highlighted item  in  column  B  into sheet COPY  . any  suggestion  make  it  more  fast  like 0.03 or 0.04  as   usaual with  simple  data?

Sub test()
    Dim ws As Worksheet, lr As Long, rCell As Range

    With Application
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
    End With

    If Application.CountA(sheet2.Range("A:A")) > 1 Then
        sheet2.Range("A2:H" & sheet2.Range("A" & Rows.Count).End(xlUp).Row).Delete xlUp
    End If

    For Each ws In ThisWorkbook.Worksheets
        If ws.Name <> "copy" Then
            lr = ws.Range("A" & Rows.Count).End(xlUp).Row
            For Each rCell In ws.Range("B2:B" & lr).Cells
                If rCell.Interior.ColorIndex <> -4142 Then
                    ws.Range("A" & rCell.Row & ":H" & rCell.Row).Copy
                    sheet2.Range("A" & sheet2.Range("A" & Rows.Count).End(xlUp).Row + 1).PasteSpecial xlPasteAll
                    Application.CutCopyMode = False
                End If
            Next rCell
        End If
    Next
    With sheet2
        .Range("A:H").Sort Key1:=.Range("B1"), Order1:=xlAscending, Header:=xlYes
        .Range("A2") = 1
        .Range("A2").AutoFill .Range("A2:A" & .Range("A" & Rows.Count).End(xlUp).Row), xlFillSeries
        .Columns("A:A").NumberFormat = "General"
        .Range("B2:B" & .Range("B" & Rows.Count).End(xlUp).Row).Interior.ColorIndex = -4142
    End With

    With Application
        .Calculation = xlCalculationAutomatic
        .ScreenUpdating = True
    End With
End Sub