Sub ertert()
Dim wsh As Worksheet, shR As Worksheet
Set shR = Sheets("â ðàáîòå")
With shR
    .Range("A3:D" & .Cells(Rows.Count, 1).End(xlUp).Row + 1).ClearContents
End With

On Error Resume Next: Err.Clear
For Each wsh In ThisWorkbook.Sheets
    If Not wsh Is shR Then
        With wsh.Range("A2").CurrentRegion
            .Parent.AutoFilterMode = False
            .AutoFilter 8, "â ðàáîòå"
            .Offset(1).Resize(, 4).Copy
            shR.Cells(Rows.Count, 1).End(xlUp)(2, 1).PasteSpecial xlPasteValues
            .AutoFilter
        End With
        If Err Then MsgBox wsh.Name & vbCrLf & Err.Description, 48: Exit Sub
    End If
Next wsh
Application.CutCopyMode = False
End Sub