Option Explicit

Sub ptrenos()
    Dim dd_&, dd1_&, ddl_1
    Dim sh As Worksheet
    Dim rr_ As String
    dd_ = Sheets("Общие расходы").Cells(Rows.Count, 1).End(xlUp).Row
    
      For Each sh In Sheets
        If sh.Name <> "Общие расходы" Then
            rr_ = sh.Name
           ddl_1 = Sheets(rr_).Cells(Rows.Count, 1).End(xlUp).Row
           Sheets(rr_).Range("$A$3:$F$" & ddl_1 + 1).ClearContents
           
           Sheets("Общие расходы").Range("$A$2:$F$" & dd_).AutoFilter Field:=4, Criteria1:=rr_
           dd1_ = Sheets("Общие расходы").Cells(Rows.Count, 1).End(xlUp).Row
           dd1_ = Sheets("Общие расходы").Range("A3:E" & dd1_).SpecialCells(xlCellTypeVisible).Copy
                With Sheets(rr_).Range("A3")
                    .PasteSpecial Paste:=xlPasteValues
                End With
        End If
        
      Next sh
      Sheets("Общие расходы").Range("$A$2:$F$" & dd_).AutoFilter
End Sub