keep source rows height during copy paste

I have a code for copy from source to target the values, formats, and column width. Unfortunately this process can't keep the height of the rows from the source to the target worksheet.

I found some short code but i can't implement in my existing code:

With SourceRange
        For r = 1 To .Rows.Count
            TargetRange.Rows(r).RowHeight = .Rows(r).RowHeight
        Next r
End With

My original macros:

Sub packinglabel()
 Dim i As Long, r As Long
 Dim a
 Dim myCell As Range
 Dim iRow As Long
 Dim LastRow As Long
 Dim FirstRow As Long
 Dim MyPrintArea As Range

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

 With Worksheets("sheet4")
    a = .Range("a6").CurrentRegion
 End With
 
 With Worksheets("sheet2")
    r = 1
     
   For i = 2 To UBound(a)
        .Range("b3") = Array(a(i, 1))
        .Range("b4") = Array(a(i, 2))
        .Range("b5") = Array(a(i, 3))
        .Range("b6") = Array(a(i, 4))
        .Range("b7") = Array(a(i, 5))
        .Range("b8") = Array(a(i, 6))
        .Range("b9") = Array(a(i, 7))
        
        .Range("b12:g12") = Array(a(i, 8), a(i, 9), a(i, 10), a(i, 11), a(i, 12), a(i, 13))
        
With Worksheets("Sheet2")
    .Range("A1:G16").Copy
    

    Worksheets("Sheet3").Range("A" & r).PasteSpecial (xlPasteValues)
    Worksheets("Sheet3").Range("A" & r).PasteSpecial (xlPasteFormats)
    Worksheets("Sheet3").Range("A" & r).PasteSpecial (xlPasteColumnWidths)
    
    Application.CutCopyMode = False
End With
             r = r + 16
    Next
 End With

With Worksheets("Sheet3")
    FirstRow = 17
    LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row

    .ResetAllPageBreaks

    For iRow = FirstRow To LastRow Step 16
        .Cells(iRow, "A").PageBreak = xlPageBreakManual
    Next iRow
    
End With
 
 
 Sheets("Sheet3").Select
    Columns("A:G").Select
    ActiveSheet.PageSetup.PrintArea = "$A:$G"
 
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

End Sub