Sub Zakaz()
Dim Sht As Worksheet
Dim iLastRow As Long
Dim iLR As Long
Dim Rng As Range
    Application.ScreenUpdating = False
       iLastRow = Cells(Rows.Count, 2).End(xlUp).Row + 1
       Range("B5:E" & iLastRow).Clear
    For Each Sht In Worksheets
      If Sht.Name <> "ВАШ ЗАКАЗ" Then
        With Sht
          .Activate
            iLR = .Cells(.Rows.Count, 2).End(xlUp).Row + 1
            Set Rng = .Range("B1:E" & iLR)
          If Not .AutoFilterMode Then
            Rng.AutoFilter
          Else
            If .FilterMode = True Then .ShowAllData
          End If
             iLastRow = Cells(Rows.Count, 2).End(xlUp).Row + 1
          Rng.AutoFilter 4, ">0"
              On Error Resume Next
          .AutoFilter.Range.Offset(1).SpecialCells(xlCellTypeVisible).Copy _
                             Worksheets("ВАШ ЗАКАЗ").Cells(iLastRow, 2)
          .AutoFilterMode = False
        End With
      End If
    Next
  Worksheets("ВАШ ЗАКАЗ").Activate
Application.ScreenUpdating = True
End Sub