Excelliste Transponieren

Sub DatenTransponieren()
    Dim i As Long
    With ActiveSheet
        With .Range("B1:E1")  
            .Value = Array("NAME", "IP", "MAC", "INFO")  
            .Font.Bold = True
        End With
        For i = 1 To .Cells(Rows.Count, "A").End(xlUp).Row Step 4  
            .Cells(i, "A").Resize(4, 1).Copy  
            .Cells(Rows.Count, "B").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues, Transpose:=True  
        Next
        .Columns(1).Delete
        .Range("A:D").EntireColumn.AutoFit  
        .ListObjects.Add(xlSrcRange, .UsedRange, , xlYes).Name = "MeinTabelle"  
    End With
End Sub