Macro - Incrémenter des données et les copiés une ligne sur deux

Bonjour,

Concernant le tableau qui dessous je veux pouvoir insérer sous macro une valeur sur deux (voir les deux tableaux), D'abord sur la ligne 1 la valeur E4, puis sur la ligne 2 la valeur D4.

Voici le résultat que je souhaite, à noter que j'ai changé de Feuille !

Merci pour votre aide !

Bonjour

Pourrais-tu joindre le fichier sur lequel figurent tes deux tableaus ? On ne peur rien faire à partir d'une image !

Bye !

Le voici !

Un essai à tester. Te convient-il ?

Option Explicit

Dim tablo, liste, listeR
Dim i&, iR&, n&, nbln&

Sub Transfromer()

    tablo = Range("A7:G" & Range("A" & Rows.Count).End(xlUp).Row)
    Set fr = Sheets("Résultat")

    nbln = WorksheetFunction.CountA(Range("A7:A" & Range("A" & Rows.Count).End(xlUp).Row)) * 3
    ReDim tablor(1 To nbln, 1 To 6)

    liste = Array(2, 1, 3, 7)
    listeR = Array(1, 3, 4, 5)

    Sheets("Résultat").Range("A1").CurrentRegion.Offset(1, 0).Clear
    iR = 1

    For i = 1 To UBound(tablo, 1)
        If tablo(i, 1) <> "" Then
            For n = 0 To 3
                tablor(iR, listeR(n)) = tablo(i, liste(n))
            Next n
            fr.Range("E" & iR + 1).Interior.Color = RGB(250, 191, 143)

            iR = iR + 1
            tablor(iR, 6) = tablo(i, 6)
            fr.Range("F" & iR + 1 & ":F" & iR + 2).Interior.Color = RGB(141, 180, 226)
            'tablor(iR, 1) = tablo(i, 1)
            iR = iR + 1
            tablor(iR, 6) = tablo(i, 5)
            'tablor(iR, 1) = tablo(i, 1)
            iR = iR + 1
        End If
    Next i
    fr.Range("A2").Resize(UBound(tablor, 1), 6) = tablor
    fr.Activate

End Sub

Bye !

C'est presque parfait !

Pourrais-tu faire la même chose pour le format du tableau en pièce jointe !

Bonjour

Bye !

Un grand merci !