Insérer lignes & copier cellule adjacente

Sub Aerer()

Dim nbLignes As Integer: Dim i As Integer
Dim plage As Range
Set plage = Selection
nbLignes = plage.EntireRow.Count
For i = 1 To nbLignes
ActiveCell.EntireRow.Insert
ActiveCell.Offset(2, 0).Select
Next i
End Sub

'Se placer au début de la selection

Sub Inserer()

    'Déclaration des variables

Dim nbLignes As Integer: Dim i As Integer
Dim plage As Range
Set plage = Selection
nbLignes = plage.EntireRow.Count
        'L'instruction "Step 3" permet ici de passer le compteur de 3 en 3 vu que l'on veux insérer 2 lignes
    For i = 1 To nbLignes * 4 Step 3
    'Insertion des 2 lignes
        Rows(i + 3).Insert
    'Ajout de la valeurs de colonne droite

     ''??

    Next i
End Sub

Bonsoir aux développeurs et développeuses aguerris,

Voici mes sombres macros destinées à insérer deux lignes sous chaque cellule non vide. Où ça se corse c'est aussi d'insérer les données situées dans le colonne de droite. L'exemple joint vous éclairera sur ce qui est attendu. Enfin j'espère.

Hello,

Une proposition :

Sub MiseEnForme()
    Dim i As Long, y As Long
    i = 5 'Ligne de départ
    y = 5
    Do While Range("e" & i).Value <> Empty 'Tant que la colonne E n'est pas vide
        Range("i" & y).Value = Range("e" & i).Value
        Range("i" & y + 1).Value = Range("g" & i).Value
        y = y + 3
        i = i + 1
    Loop
End Sub

Bonjour

Bonjour à tous

Une variante

Bye !

Bonsoir et merci à Rag02700 et gmb qui m'ont apportés chacun une solution satisfaisante pour un résultat équivalent.

C'est la classe !