Decoupage de tableau de 67 colonnes vers tableaux de 7 colonnes

Sub Transpose()
Dim a, b(), i As Long, j As Long, k As Byte, n As Long, x As Byte
    Application.ScreenUpdating = False
    a = Sheets("Feuil1").Range("A1").CurrentRegion.Value
    ReDim b(1 To UBound(a, 1) * (UBound(a, 2) / 4), 1 To 7)
    For i = 2 To UBound(a, 1)
        For j = 4 To UBound(a, 2) Step 4
            n = n + 1: x = 0
            For k = 1 To 3
                b(n, k) = a(i, k)
            Next
            For k = 4 To 7
                b(n, k) = a(i, j + x)
                x = x + 1
            Next
        Next
    Next
    'restitution et mise en Forme
    With Sheets("Feuil2").Cells(1).Resize(n, 7)
        .CurrentRegion.Clear
        .Value = [{"Lieu","Adresse","Société","Num","KE","KR","KTMA"}]
        .Offset(1).Value = b
        With .CurrentRegion
            With .Rows(1)
                .Font.Bold = True
                .Interior.ColorIndex = 40
                .BorderAround Weight:=xlThin
            End With
            .Font.Name = "calibri"
            .VerticalAlignment = xlCenter
            .HorizontalAlignment = xlCenter
            .Borders(xlInsideVertical).Weight = xlThin
            .BorderAround Weight:=xlThin
        End With
    End With
    Application.ScreenUpdating = True
End Sub

Sub test()
Dim a, b(), i As Long, j As Long, k As Byte, n As Long, x As Byte
    Application.ScreenUpdating = False
    a = Sheets("Feuil1").Range("A1").CurrentRegion.Value
    ReDim b(1 To UBound(a, 1) * (UBound(a, 2) / 4), 1 To 7)
    For i = 2 To UBound(a, 1)
        For j = 4 To UBound(a, 2) Step 4
            n = n + 1: x = 0
            For k = 1 To 3
                b(n, k) = a(i, k)
            Next
            For k = 4 To 7
                b(n, k) = a(i, j + x)
                x = x + 1
            Next
        Next
    Next
    'restitution et mise en Forme
    With Sheets("Feuil2").Cells(1).Resize(, 7)
        .CurrentRegion.Clear
        .Value = [{"Lieu","Adresse","Société","Num","KE","KR","KTMA"}]
        .Offset(1).Resize(n).Value = b
        With .CurrentRegion
            With .Offset(1, .Columns.Count).Resize(n, 1)
                .Formula = "=if(and(E2=0,F2=0,G2=0),1,"""")"
                .Value = .Value
                On Error Resume Next
                '.SpecialCells(-4123, 4).EntireRow.Delete
                .SpecialCells(2, 1).EntireRow.Delete
                On Error GoTo 0
            End With
            With .Rows(1)
                .Font.Bold = True
                .Interior.ColorIndex = 40
                .BorderAround Weight:=xlThin
            End With
            .Font.Name = "calibri"
            .VerticalAlignment = xlCenter
            .HorizontalAlignment = xlCenter
            .Borders(xlInsideVertical).Weight = xlThin
            .BorderAround Weight:=xlThin
        End With
    End With
    Application.ScreenUpdating = True
End Sub