كود يجعل ارتفاع الصفوف متساوية وكل 25 صف ورقة طباعة

[بلانك]

بالملف المرفق اريد عند طباعة الملف الصفوف تكون متساوية الارتفاع وكل 25 صف بورقة طباعة منفصلة عن الاخرى مهما تغيرت اعدادات الطباعة 

Test.xlsb

[محمد هشام.]

وعليكم السلام ورحمة الله تعالى وبركاته

لست متأكدا من طلبك لاكن حاول تجربة هدا 

Option Explicit
Private Const n As Long = 25
Private Const rHeight As Double = 20
Private Const tmps As Integer = 4
Private Const Col As String = "B"

Sub PrintWS()
    Dim lr As Long, i As Long
    Dim lastCol As Long, OnRng As Range
    Dim CrWS As Worksheet
    Dim ColNum As Long
    Set CrWS = Sheets("Data")
    
    Application.ScreenUpdating = False
    CrWS.ResetAllPageBreaks
    Application.ActiveWindow.View = xlPageBreakPreview
    
    ColNum = CrWS.Range(Col & "1").Column
    lr = CrWS.Range(Col & CrWS.Rows.count).End(xlUp).Row
    CrWS.Rows("5:" & lr).RowHeight = rHeight
    
    If lr > tmps + n Then
        For i = tmps + n + 1 To lr Step n
            CrWS.HPageBreaks.Add Before:=CrWS.Rows(i)
        Next i
    End If
    
    lastCol = CrWS.Cells(tmps, CrWS.Columns.count).End(xlToLeft).Column
    Set OnRng = CrWS.Range(CrWS.Cells(tmps, ColNum), CrWS.Cells(lr, lastCol))
    
    CrWS.PageSetup.PrintArea = OnRng.Address
    CrWS.VPageBreaks.Add Before:=CrWS.Columns(lastCol + 1)
    CrWS.VPageBreaks(1).DragOff Direction:=xlToRight, RegionIndex:=1
    
    With CrWS.PageSetup
        .Orientation = xlPortrait: .PaperSize = xlPaperA4
        .FitToPagesWide = 1: .FitToPagesTall = False
    End With
    
    Application.ScreenUpdating = True
End Sub

 

Test V1.xlsb

تم تعديل منذ 15 ساعات بواسطه محمد هشام.

[بلانك]

تمام الله يبارك فيك هو كده