XL 2019 recopier un texte avec ajout lignes vides

[lynyrd]

Bonjour le forun
Si cest possible en VBA est t'il possible de recopier un texte avec ajout de lignes vides
Merci

 

[job75]

Bonjour lynyrd,

Le code de la feuille "Résultat" :

Private Sub Worksheet_Activate()
Dim pas, source, resu(), i&, n&
pas = 4
source = Sheets("Feuil1").[A1].CurrentRegion.Resize(, 2) 'matrice, plus rapide, au moins 2 éléments
ReDim resu(1 To UBound(source) * pas, 1 To 1)
For i = 1 To UBound(source)
    resu(1 + (i - 1) * pas, 1) = source(i, 1)
Next
n = UBound(resu)
With [A1] '1ère cellule de destination, à adapter
    .Resize(n) = resu
    .Offset(n).Resize(Rows.Count - n - .Row + 1).ClearContents 'RAZ en dessous
End With
With UsedRange: End With 'actualise la barre de défilement verticale
End Sub

A+

 

[sylvanu]

Bonjour lynyrd,Job,
Un peu à labour, presque la même macro.. La macro s'exécute quand on sélectionne la feuille "Résultat voulu".

Sub Worksheet_Activate()
Dim T, S, DL%, i%
[A:A].ClearContents
With Sheets("Feuil1")
    DL = .Cells(.Cells.Rows.Count, "A").End(xlUp).Row
    T = .Range("A1:A" & DL)
End With
ReDim S(1 To 4 * UBound(T))
For i = 1 To UBound(S) Step 4
    S(i) = T(Int(1 + i / 4), 1)
Next i
[A1].Resize(UBound(S), 1).Value = Application.Transpose(S)
End Sub

 

[lynyrd]

Merci a vous 2 c'est parfait
A+