Urgent Need Rows to Convert in Coloumns (Please help)

Public Sub ProcessData()Dim Lastrow As Long
Dim Nextrow As Long
Dim i As Long
Dim cell As Range


    Application.ScreenUpdating = False
    
    With ActiveSheet
    
        .Range("E1:G1").Value = Array("Sheet name", "Clarity", "Color")
        
        Lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
        For i = 5 To Lastrow
        
            .Cells((i - 4) * 2, "E").Resize(2) = .Name
            .Cells((i - 4) * 2, "F").Resize(2) = Application.Transpose(.Range("B4:C4"))
            .Cells((i - 4) * 2, "G").Resize(2) = .Cells(i, "A").Value
            .Cells((i - 4) * 2, "H").Resize(2) = .Range("A3").Value
            .Cells((i - 4) * 2, "J").Resize(2) = Application.Transpose(.Cells(i, "B").Resize(, 2))
        Next i
        
        .Columns("E:J").AutoFit
        .Columns("A:D").Delete
    End With
    
    Application.ScreenUpdating = True
End Sub