Soru SATIRLARI BAŞLIĞIYA BERABER AYRI AYRI OTOMATİK YAZDIRMA

[smt]

Sub Alttoplamile_Satir_Satir_Yaz2()
Dim sonsat As Long

Application.ScreenUpdating = False
Application.DisplayAlerts = False

With ThisWorkbook.Worksheets("Sayfa1")
If .FilterMode Then .ShowAllData
End With

Range("A1").Select

Selection.RemoveSubtotal

Range("A1").Select
Selection.Subtotal GroupBy:=7, Function:=xlSum, TotalList:=Array(5, 6), _
    Replace:=False, PageBreaks:=True, SummaryBelowData:=True

Columns("E:F").SpecialCells(xlFormulas).Font.Bold = True

sonsat = Cells(Rows.Count, "G").End(3).Row

Range("G1:G" & sonsat).Select
    Selection.Replace What:="*Toplam*", Replacement:="", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
        
Application.DisplayAlerts = True
Application.ScreenUpdating = True

ActiveSheet.PageSetup.PrintTitleRows = "$1:$1"
ActiveSheet.PrintOut , preview:=True

ActiveSheet.ResetAllPageBreaks

Selection.RemoveSubtotal

End Sub

Necati bey çok sağolun tam istediğim gibi olmuş elinize emeğinize sağlık çok teşekkürler

 

[necati]

Rica ederim. Ufak bir ekleme ile şu yenisini kullanırsanız daha iyi olur. Açıklamalar satırlarda.

Sub Alttoplamile_Satir_Satir_Yaz2()
Dim sonsat As Long

Application.ScreenUpdating = False
Application.DisplayAlerts = False

With ThisWorkbook.Worksheets("Sayfa1")
If .FilterMode Then .ShowAllData
End With

Range("A1").Select

Selection.RemoveSubtotal

Selection.Subtotal GroupBy:=7, Function:=xlSum, TotalList:=Array(5, 6), _
    Replace:=False, PageBreaks:=True, SummaryBelowData:=True

Columns("E:F").SpecialCells(xlFormulas).Font.Bold = True


sonsat = Cells(Rows.Count, "G").End(3).Row

Range("G1:G" & sonsat).Select
    Selection.Replace What:="*Toplam*", Replacement:="", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False

'Range("E" & sonsat & ":G" & sonsat).Delete 'Son satırdaki genel toplamı silmek için gerekirse bu satırı aktif edersiniz

Application.DisplayAlerts = True
Application.ScreenUpdating = True

ActiveSheet.PageSetup.PrintTitleRows = "$1:$1"
ActiveSheet.PrintOut , preview:=True

Range("A1").Select    'Bu satır da muhtemel bir hataya karşı ilave edildi.

ActiveSheet.ResetAllPageBreaks

Selection.RemoveSubtotal

End Sub