Excel vba copy values from one sheet to another insert row / transpose

excel vba report getting in wrong formats. codes and screenshots attached.

Sub TransferDataAndInsertRows()

Dim ws1 As Worksheet, ws2 As Worksheet
Dim row1 As Long, row2 As Long
Dim col As Long
Dim numNonBlanks As Long

Set ws1 = Worksheets("Sheet1")
Set ws2 = Worksheets("Sheet2")

row1 = 4 ' Starting row in Sheet1
row2 = 9 ' Starting row in Sheet2

Do While ws1.Cells(row1, 2).Value <> ""

' Copy particulars and amount to Sheet2
ws2.Cells(row2, 4).Value = ws1.Cells(row1, 2).Value
ws2.Cells(row2, 7).Value = ws1.Cells(row1, 3).Value

' Count non-blank cells in D4:M4
numNonBlanks = Application.WorksheetFunction.CountA(ws1.Range("D" & row1 & ":M" & row1))

' Insert rows in Sheet2 if needed
If numNonBlanks > 0 Then
ws2.Rows(row2 + 1 & ":" & row2 + numNonBlanks).Insert Shift:=xlDown
End If

' Copy non-blank values from D4:M4 to Sheet2
col = 5
For i = 4 To 13
If ws1.Cells(row1, i).Value <> "" Then
ws2.Cells(row2 + 1, col).Value = Application.Transpose(ws1.Cells(row1, i).Value)
col = col + 1
End If
Next i

row1 = row1 + 1
row2 = row2 + numNonBlanks + 1

Loop

End Sub

====
screenshots
sheet1
sh1.jpg

sheet2-getting wrong report as per above code.
sh2wrongformat.jpg

sheet2 output report should be
sh2 correct.jpg