Decoupage de tableau de 67 colonnes vers tableaux de 7 colonnes

[Profane]

Bonjour à tous ,

je m'adresse en particulier au pro du découpage ,
la solution passe certainement par l'utilisation d'un tablo, mais je suis une quiche (et je suis modeste)

en gros j'ai un tableau comportant 3 colonnes fixes, suivit de 16 trio (précédé chacun de leur numéro respectif)
l'idée est de dupliquer par lignes les 3 colonnes fixes et de les faire suivre par un trio,
ce qui fait 16 lignes au maxi, car je souhaite n'importer que les trios "rempli" au niveau data

en piece jointe une vision de l'existant avec ce que j'espererai comme resultat
ce sera sans doute plus "parlant"

@+ et merci d'avance pour votre aide

 

[phlaurent55]

Re : Decoupage de tableau de 67 colonnes vers tableaux de 7 colonnes

Bonjour Profane,

voir fichier joint

à+
Philippe

 

[Profane]

Re : Decoupage de tableau de 67 colonnes vers tableaux de 7 colonnes

un mot splendide,
c'est rapide et efficace
merci enormément phlaurent

 

[klin89]

Re : Decoupage de tableau de 67 colonnes vers tableaux de 7 colonnes

Bonsoir Profane, phlaurent55, le forum

Résultat en Feuil2 :

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

Klin89

 

[klin89]

Re : Decoupage de tableau de 67 colonnes vers tableaux de 7 colonnes

re Profane,

Le code réajusté :

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

Klin89