Aide très importante pour une macro

Bonjour svp

J'ai un fichier à retraiter très régulièrement qui comporte des milliers de lignes, j'en ai extrait une petite partie (en prenant soin de falsifier les données se trouvant dessus vous pourrez le remarquer par vous-même)

Alors, j'ai un peu écris le code d'abord en algorithmique, puis en info mais ça marche pas du tout, je précise que j'ai pas de niveau en ça c'est juste du bidouillage

Alors :

1 : Supprimer toutes les lignes vides

2 : Se positionner sur la ligne 2

De la ligne 2 jusqu'à la fin :

3 : Copier le contenu des cellules une ligne en dessous (de la ligne sur laquelle on est positionné) de C à H une ligne au dessus

4 : Copier le contenu des cellules deux lignes en dessous (de la ligne sur laquelle on est positionné) de I à N deux lignes au dessus

5 : Copier le contenu des cellules trois lignes en dessous (de la ligne sur laquelle on est positionné) de O à R trois lignes au dessus

Et donc là on a 3 lignes en dessous qui sont quasi vide, donc supprimer les deux en dessous de celle sur laquelle on est positionne (en début de boucle 2), on en supprime deux, et on fait + 1, et en étant ligne 3, on se retrouve à la même position que la ligne 2 tout à l'heure donc on réitère

Donc :

6 : Supprimer les deux lignes en dessous

7 : Ligne = ligne + 1

DONC maintenant en tentative de prog ce que ça donne

Sub Ameliorer_fichier

1 : Range("A1:A65536").SpecialCells(xlCellTypeBlanks).EntireRow.Delete

2 : For i = 2 to 50000

3 : Range("C:H" & (ActiveCell.Row + 1)).Copy

3 : Range("C:H" & (ActiveCell.Row)).Paste

4 : Range("I:N" & (ActiveCell.Row + 2)).Copy

4 : Range("I:N" & (ActiveCell.Row)).Paste

5 : Range("O:R" & (ActiveCell.Row + 3)).Copy

5 : Range("O:R" & (ActiveCell.Row)).Paste

6 : ActiveSheet.Rows(ActiveCell.Row+1).EntireRow.Delete

6 : ActiveSheet.Rows(ActiveCell.Row).EntireRow.Delete

7 : i+1

Next

End Sub

Voilà je sais que c'est faux mais au moins j'aurais essayé

bonjour,

une proposition

Sub Ameliorer_fichier()
    Range("A:A").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    i = 2
    While Cells(i, 1) <> ""
        If Cells(i, 5) <> "" Then
            Range("I" & i + 1 & ":N" & i + 1).Copy Range("I" & i)
            Range("O" & i + 2 & ":R" & i + 2).Copy Range("O" & i)
            Rows(i + 1 & ":" & i + 2).Delete shift:=xlUp
            i = i + 1
        Else
            Rows(i).Delete shift:=xlUp
        End If
    Wend
End Sub

Wouah c'est excellent ça fonctionne parfaitement

Merci beaucoup et rien à voir avec mon code ahah

Finalement ça ne fonctionne pas si parfaitement que ça :/

La colonne M s'efface après l'exécution de la macro quelqu'un saurait régler ça svp ???

Merci beaucoup

EDIT : Finalement j'ai réglé ça comme un grand