Copier lignes selon un procédé bien précis

Bonjour à tous,

J’ai encore besoin de vos services, à savoir pour copier des grandes quantités de données selon un procédé spécifique, je m’explique :

Pour commencer, mes données se trouvent dans le Range suivant : "A2:I" & Dernière ligne, on ne doit pas s’occuper des données qui se trouvent après la colonne "I"

La Feuille source est : Feuille "Impression"

La Feuille de destination est : Feuille "1^er_Tour"

Je souhaite copier les lignes du range spécifié en partant de la ligne n° 2, pour copier les lignes tous les 3 lignes, ce qui revient à dire qu’on va copier les lignes suivantes : 2, 5, 8, 11, 14, 17 …. , 56, 59)

La copie se fera dans la feuille "1^er_Tour" à partir de la 2^e ligne.

Ensuite, on va copier les lignes du range spécifié en partant de la ligne n° 3, pour copier les lignes tous les 3 lignes, ce qui revient à dire qu’on va copier les lignes suivantes : 3, 6, 9, 12, 15, 18 …. , 57, 60)

La copie se fera dans la feuille "1^er_Tour" à partir de la (dernière ligne + 1) de la feuille "1^er_Tour", de manière à laisser une 2^e ligne vide entre les deux copie.

Et enfin, on va copier les lignes du range spécifié en partant de la ligne n° 4, pour copier les lignes tous les 3 lignes, ce qui revient à dire qu’on va copier les lignes suivantes : 4, 7, 10, 13, 16, 19 …. , 58, 61)

La copie se fera dans la feuille "1^er_Tour" à partir de la dernière ligne + 1, de la feuille "1^er_Tour", de manière à laisser une 2^e ligne vide.

Sauf erreur de ma part, le résultat final se trouve dans la feuille "1^er_Tour".

Un petit détail à ne pas négliger, je souhaite aussi copier les entêtes (première ligne de la feuille "Impression"), vers la première ligne de la feuille "1^er_Tour".

Je reste à votre disposition au besoin.

PS : Je me permet de vous demander un solution en vba et non avec Power Query car j’aurais besoin de la Macro dans d’autres projets.

Je vous remercie d’avance pour vos contributions.

Salut Harzer,

un truc comme ça?

Public Sub CopyCell()
'
Dim tTab, tData, iRow%, iIdx%
'
With Worksheets("Impression")
    iRow = .Range("A" & Rows.Count).End(xlUp).Row
    tTab = .Range("A1:I" & iRow).Value
    tData = .Range("AA1").Resize(iRow + 2, 9).Value
    For x = 1 To 3
        iIdx = iIdx + 1
        If x = 1 Then
            For y = 1 To 9
                tData(1, y) = tTab(1, y)
            Next
        End If
        For y = (1 + x) To UBound(tTab, 1) Step 3
            iIdx = iIdx + 1
            For Z = 1 To 9
                tData(iIdx, Z) = IIf(x > 1 And Z = 5, tTab(y - (x - 1), Z), tTab(y, Z))
            Next
        Next
    Next
End With
With Worksheets("1er_Tour")
    .Cells.ClearContents
    .Range("A1").Resize(UBound(tData, 1), 9).Value = tData
    .Activate
End With
'
End Sub

A+

bonjour Harzer,

un essai, j'ai ajouté une MFC parce qu'il y a des défauts je crois ...

EDIT : salut Curulis, bienvenu !!!

Salut BsAlv,

je pense qu'on va arriver un jour à avoir des cartes de fidélité de Harzer!

A+

Bonjour Curulis et BsAlv,

Je suis très content de vous retrouver tous les deux, les deux codes que vous me proposer sont Nikel ! ils me donnent tous les deux le bon résultat, cerise sur le gâteau, ils sont très rapide.

J’ai trouvé la blague de Curulis très amusante concernant la carte de fidélité. En tout cas, il y’a quelques choses (Genre des aimants qui s’attirent) qui fait que lorsque la discussion est lancée, on se retrouvent (Assez souvent) tous les trois au rendez-vous, c’est Magique !

En ce qui concerne BsAlv , il y’a bien longtemps qu’il m’apporte son aide appréciable, Idem pour Curulis.

Je dois marquer que le sujet est résolu et que le post que j’ai chosit est la solution, or, les deux solutions sont très bonnes.

Comme Curulis m’a proposé sa solution en premier à quelques minutes près, je vais choisir son post comme la solution or les deux propositions sont la solution.

Je vous remercient et au plaisir de vous lire à l’occasion.