XL pour MAC insérer une ligne qui copie la précédente à chaque changement de valeur

  • Initiateur de la discussion Initiateur de la discussion herve30
  • Date de début Date de début

Boostez vos compétences Excel avec notre communauté !

Rejoignez Excel Downloads, le rendez-vous des passionnés où l'entraide fait la force. Apprenez, échangez, progressez – et tout ça gratuitement ! 👉 Inscrivez-vous maintenant !

herve30

XLDnaute Nouveau
Bonjour,
Je souhaite insérer une ligne qui copie la précédente à chaque changement de valeur
Je fais pour ajouter la ligne :

Sub insérer()
Dim Ligne As Long

For Ligne = Range("A1").End(xlDown).Row To 2 Step -1
If Range("A" & Ligne) <> Range("A" & Ligne - 1) Then
Range("A" & Ligne).EntireRow.Insert
End If
Next
End Sub

Mais je n'arrive pas à modifier pour copier la ligne précédente !
Merci d'avance
Cordialement
 

Pièces jointes

Solution
Bonjour à tous 🙂

Attention! C'est une macro qui ne doit être exécutée qu'une fois car on modifie les données sources.
Si vous le désirez, on pourrait afficher le résultat sur une autre feuille afin de préserver les données initiales.

Essayer ce code dans le module de la feuille "Feuill1":
VB:
Sub dupliquer()
Dim der&, ref, n&, i&
   Application.ScreenUpdating = False
   With ActiveSheet
      If .FilterMode Then .ShowAllData
      der = .Cells(Rows.Count, "a").End(xlUp).Row
      For i = der To 1 Step -1
         If .Cells(i, "a") = ref Then
            n = n + 1
         Else
            If n > 1 Then
               .Rows(i + 1).Insert
               .Rows(i + 2).Copy Rows(i + 1)
            End If
            ref = .Cells(i, "a")...
Bonjour Hervé,
Si j'ai bien compris, essayez :
VB:
Sub insérer()
    Dim Ligne As Long
    For Ligne = Range("A1").End(xlDown).Row To 2 Step -1
        If Range("A" & Ligne) <> Range("A" & Ligne - 1) Then
            Range("A" & Ligne).EntireRow.Insert
            Rows(Ligne + 1).Copy Rows(Ligne)
        End If
    Next
End Sub
 
Bonjour Hervé,
J'ai un peu de mal à comprendre entre les deux demandes :
Je souhaite insérer une ligne qui copie la précédente à chaque changement de valeur
Donc 12345 doit être dupliquée puisqu'ensuite il y a 5678.
Mais j'aimerai limiter cet ajout pour les lignes qui ont la même référence
12345 n'est pas dupliquée dans votre exemple alors qu'ensuite on trouve 5678.
Vous pouvez être plus précis ?
Tentative :
Une ligne est dupliqué que si on a un changement de référence ET que les lignes suivantes ont une même référence.
 
Bonjour,
Désolé si je me suis mal fait comprendre .
Vous dites :
Tentative :
Une ligne est dupliqué que si on a un changement de référence ET que les lignes suivantes ont une même référence.

Oui c'est bien çà !
Petite explication:
Dans le fichier joint on voit:
En A2 12345 est une Réf unique donc la ligne n'est pas dupliqué
idem pour toutes les Réf uniques (A12-151617, A13-181920 ... )
En A3 5678 a des Réf multiples (en A4) on ajoute donc une ligne au dessus de A3
qui duplique le contenu de la ligne du dessous
Idem pour la Réf A5 91011 et en A8 121314

J’espère être un peu plus clair
Je reste à vote disposition
Cordialement
 
Dernière édition:
Bonjour à tous 🙂

Attention! C'est une macro qui ne doit être exécutée qu'une fois car on modifie les données sources.
Si vous le désirez, on pourrait afficher le résultat sur une autre feuille afin de préserver les données initiales.

Essayer ce code dans le module de la feuille "Feuill1":
VB:
Sub dupliquer()
Dim der&, ref, n&, i&
   Application.ScreenUpdating = False
   With ActiveSheet
      If .FilterMode Then .ShowAllData
      der = .Cells(Rows.Count, "a").End(xlUp).Row
      For i = der To 1 Step -1
         If .Cells(i, "a") = ref Then
            n = n + 1
         Else
            If n > 1 Then
               .Rows(i + 1).Insert
               .Rows(i + 2).Copy Rows(i + 1)
            End If
            ref = .Cells(i, "a")
            n = 1
         End If
      Next i
   End With
End Sub
 

Pièces jointes

Dernière édition:
- Navigue sans publicité
- Accède à Cléa, notre assistante IA experte Excel... et pas que...
- Profite de fonctionnalités exclusives
Ton soutien permet à Excel Downloads de rester 100% gratuit et de continuer à rassembler les passionnés d'Excel.
Je deviens Supporter XLD

Discussions similaires

Réponses
3
Affichages
193
Réponses
10
Affichages
281
  • Question Question
Microsoft 365 worksheet_change
Réponses
29
Affichages
479
Réponses
4
Affichages
177
Retour