так надо?
[vba]Код
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
[/vba]