XL 2013 VB, chercher doublons puis déplacer ligne

K

karamoko512

XLDnaute Nouveau
Bonjour,
J'ai un souci avec une macro qui me prend la tête depuis.
Je voudrais chercher les doublons dans la colonne A et si doublon il y a, il faudra déplacer la ligne du doublon, par exemple de la plage A11:Q11 vers R10.
Merci
 

Pièces jointes

  • Base de donnees originales 280121 ok test.xlsx
    488 KB · Affichages: 26
Trier par date Trier par votes
Dudu2

Dudu2

XLDnaute Barbatruc
Bonjour,
Identifier les doublons peut se faire par une MFC.
Éventuellement trier puis ajouter les colonnes à partir de R pour les doublons avec des formules comparant le précédent.
Mais déplacer je ne vois pas comment ce serait possible avec des formules car on ne peut pas à la fois utiliser la valeur d'une cellule pour la comparer à une autre et la vider sous condition d'égalité.
Il faut passer par du VBA.
 
Vote positif 0 Vote négatif
Robert

Robert

XLDnaute Barbatruc
Repose en paix
Bonsoir karamoko, bonsoir le forum,

Mon PC n'est pas un foudre de guerre et même si j'ai fait le plein de charbon il a mis 124 secondes pour traiter uniquement l'onglet Base de données originales. J'ai modifié ta requête car j'ai vu qu'il pouvait y avoir plus d'un seul doublon. Dans ce cas les lignes en doublon sont ajoutées à la fin de la ligne originale (colonnes R, AI, etc.)
Le code ci-dessous n'agit que sur l'onglet Base de données originales, si tu veux agir sur tous le classeur il faudra boucler sur tous les onglet mais ça va allonger le temps de traitement.
Code 1er onglet seulement :
VB: 
Sub Macro1()
Dim OB As Worksheet 'déclare la variable OB (Onglet Base)
Dim DL As Integer 'déclare la variable DL (Dernière Ligne)
Dim PL As Range 'déclare la variable PL (OLage)
Dim I As Integer 'déclare la variable I (Incrément)
Dim J As Integer 'déclare la variable J (incrément)
Dim PCV As Integer 'déclare la variable PCV (Première Colonne Vide)

Application.ScreenUpdating = False 'masque les rafraîchissements d'écran
deb = Timer 'début du chronométarge
Set OB = Worksheets("Base de données originales") 'définit l'onglet OB
DL = OB.Cells(Application.Rows.Count, "A").End(xlUp).Row 'définit la dernière ligne éditée DL de la colonne A de l'onglet OB
Set PL = OB.Range("A1:Q" & DL) 'définit la plage PL
For I = DL To 2 Step -1 'boucle 1 : inversée des lignes DL à 2 en remontant
    For J = DL To 2 Step -1 'boucle 2 : inversée des lignes DL à 2 en remontant
        If I <> J And OB.Cells(I, "A") = OB.Cells(J, "A") Then 'si I est diférent de J et la cellule ligne I colonne A est égale à la cellule ligne J colonne A
            PCV = OB.Cells(I, Application.Columns.Count).End(xlToLeft).Column + 1 'définit la première colonne vide PCV de la ligne I
            OB.Cells(J, "A").Resize(1, 17).Copy OB.Cells(I, PCV) 'copy la cellule ligne J colonne A redimensionné de 17 colonne (soit la plage A:Q de la ligne J) dans le celllule ligne I colonne PCV
            OB.Rows(J).Delete 'supprime la ligne J
        End If 'fin de la condition
    Next J 'prochaine ligne de la boucle 2
Next I 'prochaine ligne de la boucle 1
Application.ScreenUpdating = True 'affiche les rafraîchissements d'écran
MsgBox "Données traitées  en " & Timer - deb & " !" 'message
End Sub
Code pour tout le classeur :
Code: 
Sub Macro1()
Dim O As Worksheet 'déclare la variable O (Onglet)
Dim DL As Integer 'déclare la variable DL (Dernière Ligne)
Dim PL As Range 'déclare la variable PL (OLage)
Dim I As Integer 'déclare la variable I (Incrément)
Dim J As Integer 'déclare la variable J (incrément)
Dim PCV As Integer 'déclare la variable PCV (Première Colonne Vide)

Application.ScreenUpdating = False 'masque les rafraîchissements d'écran
deb = Timer 'début du chronométarge
For Each O In Sheets 'boucle sur tous les onglets O du claseur
    DL = O.Cells(Application.Rows.Count, "A").End(xlUp).Row 'définit la dernière ligne éditée DL de la colonne A de l'onglet O
    Set PL = O.Range("A1:Q" & DL) 'définit la plage PL
    For I = DL To 2 Step -1 'boucle 2 : inversée des lignes DL à 2 en remontant
        For J = DL To 2 Step -1 'boucle 3 : inversée des ligne DL à 2 en remontant
            If I <> J And O.Cells(I, "A") = O.Cells(J, "A") Then 'si I est diférent de J et la cellule ligne I colonne A est égale à la cellule ligne J colonne A
                PCV = O.Cells(I, Application.Columns.Count).End(xlToLeft).Column + 1 'définit la première colonne vide PCV de la ligne I
                O.Cells(J, "A").Resize(1, 17).Copy O.Cells(I, PCV) 'copy la cellule ligne J colonne A redimensionné de 17 colonne (soit la plage A:Q de la ligne J) dans le celllule ligne I colonne PCV
                O.Rows(J).Delete 'supprime la ligne J
            End If 'fin de la condition
        Next J 'prochaine ligne de la boucle 3
    Next I 'prochaine ligne de la boucle 2
Next O 'prochain onglet de la boucle 1
Application.ScreenUpdating = True 'affiche les rafraîchissements d'écran
MsgBox "Données traitées  en " & Timer - deb & " !" 'message
End Sub
 
Vote positif 0 Vote négatif
K

karamoko512

XLDnaute Nouveau
Robert à dit:
Bonsoir karamoko, bonsoir le forum,

Mon PC n'est pas un foudre de guerre et même si j'ai fait le plein de charbon il a mis 124 secondes pour traiter uniquement l'onglet Base de données originales. J'ai modifié ta requête car j'ai vu qu'il pouvait y avoir plus d'un seul doublon. Dans ce cas les lignes en doublon sont ajoutées à la fin de la ligne originale (colonnes R, AI, etc.)
Le code ci-dessous n'agit que sur l'onglet Base de données originales, si tu veux agir sur tous le classeur il faudra boucler sur tous les onglet mais ça va allonger le temps de traitement.
Code 1er onglet seulement :
VB: 
Sub Macro1()
Dim OB As Worksheet 'déclare la variable OB (Onglet Base)
Dim DL As Integer 'déclare la variable DL (Dernière Ligne)
Dim PL As Range 'déclare la variable PL (OLage)
Dim I As Integer 'déclare la variable I (Incrément)
Dim J As Integer 'déclare la variable J (incrément)
Dim PCV As Integer 'déclare la variable PCV (Première Colonne Vide)

Application.ScreenUpdating = False 'masque les rafraîchissements d'écran
deb = Timer 'début du chronométarge
Set OB = Worksheets("Base de données originales") 'définit l'onglet OB
DL = OB.Cells(Application.Rows.Count, "A").End(xlUp).Row 'définit la dernière ligne éditée DL de la colonne A de l'onglet OB
Set PL = OB.Range("A1:Q" & DL) 'définit la plage PL
For I = DL To 2 Step -1 'boucle 1 : inversée des lignes DL à 2 en remontant
    For J = DL To 2 Step -1 'boucle 2 : inversée des lignes DL à 2 en remontant
        If I <> J And OB.Cells(I, "A") = OB.Cells(J, "A") Then 'si I est diférent de J et la cellule ligne I colonne A est égale à la cellule ligne J colonne A
            PCV = OB.Cells(I, Application.Columns.Count).End(xlToLeft).Column + 1 'définit la première colonne vide PCV de la ligne I
            OB.Cells(J, "A").Resize(1, 17).Copy OB.Cells(I, PCV) 'copy la cellule ligne J colonne A redimensionné de 17 colonne (soit la plage A:Q de la ligne J) dans le celllule ligne I colonne PCV
            OB.Rows(J).Delete 'supprime la ligne J
        End If 'fin de la condition
    Next J 'prochaine ligne de la boucle 2
Next I 'prochaine ligne de la boucle 1
Application.ScreenUpdating = True 'affiche les rafraîchissements d'écran
MsgBox "Données traitées  en " & Timer - deb & " !" 'message
End Sub
Code pour tout le classeur :
Code: 
Sub Macro1()
Dim O As Worksheet 'déclare la variable O (Onglet)
Dim DL As Integer 'déclare la variable DL (Dernière Ligne)
Dim PL As Range 'déclare la variable PL (OLage)
Dim I As Integer 'déclare la variable I (Incrément)
Dim J As Integer 'déclare la variable J (incrément)
Dim PCV As Integer 'déclare la variable PCV (Première Colonne Vide)

Application.ScreenUpdating = False 'masque les rafraîchissements d'écran
deb = Timer 'début du chronométarge
For Each O In Sheets 'boucle sur tous les onglets O du claseur
    DL = O.Cells(Application.Rows.Count, "A").End(xlUp).Row 'définit la dernière ligne éditée DL de la colonne A de l'onglet O
    Set PL = O.Range("A1:Q" & DL) 'définit la plage PL
    For I = DL To 2 Step -1 'boucle 2 : inversée des lignes DL à 2 en remontant
        For J = DL To 2 Step -1 'boucle 3 : inversée des ligne DL à 2 en remontant
            If I <> J And O.Cells(I, "A") = O.Cells(J, "A") Then 'si I est diférent de J et la cellule ligne I colonne A est égale à la cellule ligne J colonne A
                PCV = O.Cells(I, Application.Columns.Count).End(xlToLeft).Column + 1 'définit la première colonne vide PCV de la ligne I
                O.Cells(J, "A").Resize(1, 17).Copy O.Cells(I, PCV) 'copy la cellule ligne J colonne A redimensionné de 17 colonne (soit la plage A:Q de la ligne J) dans le celllule ligne I colonne PCV
                O.Rows(J).Delete 'supprime la ligne J
            End If 'fin de la condition
        Next J 'prochaine ligne de la boucle 3
    Next I 'prochaine ligne de la boucle 2
Next O 'prochain onglet de la boucle 1
Application.ScreenUpdating = True 'affiche les rafraîchissements d'écran
MsgBox "Données traitées  en " & Timer - deb & " !" 'message
End Sub
Cliquez pour agrandir...
Bonjour Robert,

C'est exactement ce que je cherchais. Mais j'ai omis de préciser quelque chose. Est-ce possible de mettre en premier, le doublon ayant la plus ancienne date et les autres à la suite. C'est a dire comparer les dates de la colonne E. La ligne de la plus ancienne date commencera à partir de la colonne A et les autre lignes suivent ensuite (c'est a dire qu'elles sont déplacées à la suite de l'autre). Merci
 
Vote positif 0 Vote négatif
Robert

Robert

XLDnaute Barbatruc
Repose en paix
Re,

Pfff... J'ai galéré... Mais la durée d'exécution a été considérablement diminuée. J'ai séparé la base des autres onglets car dans celle-ci les dates sont en colonne 4 et en colonne 5 pour les autres :
VB: 
Option Explicit

Sub Macro1()
Dim DEB As Double ' déclare la variable DEB (DÉBut)
Dim OB As Worksheet 'déclare la variable OB (Onglet Base)
Dim D As Object 'déclare la variable D (Dictionnaire)
Dim DL As Integer 'déclare la variable DL (Dernière Ligne)
Dim PL As Range 'déclare la variable PL (PLage)
Dim PC As Range 'déclare la variable PL (Première Colonne)
Dim I As Long 'déclare la variable I (Incrément)
Dim J As Long 'déclare la variable J (incrément)
Dim K As Long 'déclare la variable J (incrément)
Dim M As Integer 'déclare la variable J (incrément)
Dim N As Integer 'déclare la variable J (incrément)
Dim PCV As Integer 'déclare la variable PCV (Première Colonne Vide)
Dim TV As Variant 'déclare la variable TV (Tableau des Valeurs)
Dim TD() As Variant 'déclare la variable TD (Tableau des Doublons)
Dim R As Range 'déclare la variable R (Recherche)
Dim TMP As Variant 'déclare la variable TMP (TeMPoraire)
Dim PAS As Range 'déclare la variable PAS (Plage à Supprimer))

Application.ScreenUpdating = False 'masque les rafraîchissements d'écran
DEB = Timer 'début du chronométarge

'onglet "Base de données originales" (les dates sont en colonne 4 (= D)
Set OB = Worksheets("Base de données originales") 'définit l'onglet OB
Set D = CreateObject("Scripting.Dictionary") 'définit le dictionnaire D
Set PAS = OB.Range("A1") 'initialise la plage à supprimer PAS
DL = OB.Cells(Application.Rows.Count, "A").End(xlUp).Row 'définit la dernière ligne éditée DL de la colonne A de l'onglet OB
Set PL = OB.Range("A1:Q" & DL) 'définit la plage PL
Set PC = OB.Range("A1:A" & DL) 'définit la plage PL (la première colonne de PL)
TV = PL 'définit le tableau de valeurs TV
For I = DL To 2 Step -1 'boucle inversée sur toutes les lignes I du tableau des valeurs TV (de DL à 2)
    If D.exists(TV(I, 1)) Then GoTo suite 'si la donnée ligne I colonne 1 de TV existe dans le dictionnaire D, va à l'étiquette "suite"
    D(TV(I, 1)) = "" 'ajoute la donnée ligne I colonne 1 de TV au dictionnaire D
    K = 0 'initialise K
    If Application.WorksheetFunction.CountIf(PC, TV(I, 1)) > 1 Then 'condition 1 : si le nombre de fois que la donnée ligne I colonne 1 de TV existe dans la plage PC est supérieur à 1
        K = K + 1 'incrémente K
        ReDim Preserve TD(1 To 2, 1 To K) 'redimensionne le tableau des doublons TD (2 lignes, K colonnes)
        TD(1, K) = I 'récupère le numéro de ligne I dans la ligne de TD
        TD(2, K) = CLng(DateSerial(Year(TV(I, 4)), Month(TV(I, 4)), Day(TV(I, 4)))) 'récupère la date (en entier long) de la donnée ligne I colonne 4 de TV dans la ligne 2 de TD
        Set R = PC.Find(TV(I, 1), OB.Cells(I, 1), , , , xlPrevious, xlValues, xlWhole) 'définit la recherche R (Recherche au-dessous un nouvelle occurrence exacte de la données ligne I colonne 1de TV dans la plage PC)
        Do 'exécute
            K = K + 1 ' incrémente K
            ReDim Preserve TD(1 To 2, 1 To K)
            TD(1, K) = R.Row 'récupère le numéro de ligne de la l'occurrence trouvée dans la ligne de TD
            TD(2, K) = CLng(DateSerial(Year(PC(R.Row, 4).Value), Month(PC(R.Row, 4).Value), Day(PC(R.Row, 4).Value))) 'récupère la date (en entier long) de l'occurrence trouvée dans la ligne 2 de TD
            Set R = PC.FindPrevious(R) 'redéfinit la recherche R (occurrence précédente)
        Loop While Not R Is Nothing And R.Row <> I 'boucle tant qu'il existe des occurrence ailleurs que dans la ligne I
        'tri selon des dates
        For M = 1 To K 'boucle 1 : sur toutes les valeur du tableau des doublons (de 1 à K)
            For N = 1 To K 'boucle 2 : sur tous les doublons du tableau TD ( de 1 à K)
                If M <> N And TD(2, N) < TD(2, M) Then 'condition 2 : si M est différent de N est les dates sont identiques
                    TMP = TD(1, M): TD(1, M) = TD(1, N): TD(1, N) = TMP 'tri les numéro de lignes
                    TMP = TD(2, M): TD(2, M) = TD(2, N): TD(2, N) = TMP 'tri les dates
                End If 'fin de la contition 2
            Next N 'prochaine valeur N
        Next M 'prochaine valeur M
        'le tableau des doublons TD est maintenant trié de la date la plus récente à la date la plus ancienne
        For M = 2 To K 'boucle sur toutes les valeurs du tableau des doublons (en partant de la seconde, de 2 à K)
            PCV = OB.Cells(TD(1, 1), Application.Columns.Count).End(xlToLeft).Column + 1 'définit la première colonne vide PCV de la ligne la plus ancienne
            OB.Cells(TD(1, M), "A").Resize(1, 17).Copy OB.Cells(TD(1, 1), PCV) 'copy la cellule ligne TD(1,M) colonne A redimensionné de 17 colonne (soit la plage A:Q de la ligne TD(1,M)) dans le celllule ligne I colonne PCV
            Set PAS = IIf(PAS.Cells.Count = 1, OB.Rows(TD(1, M)), Application.Union(PAS, OB.Rows(TD(1, M)))) 'redéfinit la plage à supprimer PAS
        Next M 'prochain valeur de la boucle
    End If 'fin de la condition 1
suite: 'étiquette
Next I 'prochaine ligne de la boucle 1 (en remontant)
PAS.Delete 'supprime la plage PAS

'tous les autres onglets (les dates sont en colonne 5 (= E)
For Each OB In Sheets 'boucle : sur tous les onglets du classeur
    If OB.Name <> "Base de données originales" Then 'condition : si l'onglet ne se nomme pas "Base de données originales"
        Set D = CreateObject("Scripting.Dictionary")
        Set PAS = OB.Range("A1")
        DL = OB.Cells(Application.Rows.Count, "A").End(xlUp).Row
        Set PL = OB.Range("A1:Q" & DL)
        Set PC = OB.Range("A1:A" & DL)
        TV = PL
        For I = DL To 2 Step -1
            If D.exists(TV(I, 1)) Then GoTo suite2
            D(TV(I, 1)) = ""
            K = 0
            If Application.WorksheetFunction.CountIf(PC, TV(I, 1)) > 1 Then
                K = K + 1
                ReDim Preserve TD(1 To 2, 1 To K)
                TD(1, K) = I
                TD(2, K) = CLng(DateSerial(Year(TV(I, 5)), Month(TV(I, 5)), Day(TV(I, 5))))
                Set R = PC.Find(TV(I, 1), OB.Cells(I, 1), , , , xlPrevious, xlValues, xlWhole)
                Do
                    K = K + 1
                    ReDim Preserve TD(1 To 2, 1 To K)
                    TD(1, K) = R.Row
                    TD(2, K) = CLng(DateSerial(Year(PC(R.Row, 5).Value), Month(PC(R.Row, 5).Value), Day(PC(R.Row, 5).Value)))
                    Set R = PC.FindPrevious(R)
                Loop While Not R Is Nothing And R.Row <> I
                For M = 1 To K
                    For N = 1 To K
                        If M <> N And TD(2, N) < TD(2, M) Then
                            TMP = TD(1, M): TD(1, M) = TD(1, N): TD(1, N) = TMP
                            TMP = TD(2, M): TD(2, M) = TD(2, N): TD(2, N) = TMP
                        End If
                    Next N
                Next M
                For M = 2 To K
                    PCV = OB.Cells(TD(1, 1), Application.Columns.Count).End(xlToLeft).Column + 1 'définit la première colonne vide PCV de la ligne la plus ancienne
                    OB.Cells(TD(1, M), "A").Resize(1, 17).Copy OB.Cells(TD(1, 1), PCV) 'copy la cellule ligne J colonne A redimensionné de 17 colonne (soit la plage A:Q de la ligne J) dans le celllule ligne I colonne PCV
                    Set PAS = IIf(PAS.Cells.Count = 1, OB.Rows(TD(1, M)), Application.Union(PAS, OB.Rows(TD(1, M))))
                Next M
            End If
suite2:
        Next I
        PAS.Delete
    End If 'fin de la condition
Next OB 'prochain onglet de la boucle

Application.ScreenUpdating = True 'affiche les rafraîchissements d'écran
MsgBox "Données traitées  en " & Timer - DEB & " !" 'message
End Sub
 
Vote positif 0 Vote négatif
K

karamoko512

XLDnaute Nouveau
Robert à dit:
Re,

Pfff... J'ai galéré... Mais la durée d'exécution a été considérablement diminuée. J'ai séparé la base des autres onglets car dans celle-ci les dates sont en colonne 4 et en colonne 5 pour les autres :
VB: 
Option Explicit

Sub Macro1()
Dim DEB As Double ' déclare la variable DEB (DÉBut)
Dim OB As Worksheet 'déclare la variable OB (Onglet Base)
Dim D As Object 'déclare la variable D (Dictionnaire)
Dim DL As Integer 'déclare la variable DL (Dernière Ligne)
Dim PL As Range 'déclare la variable PL (PLage)
Dim PC As Range 'déclare la variable PL (Première Colonne)
Dim I As Long 'déclare la variable I (Incrément)
Dim J As Long 'déclare la variable J (incrément)
Dim K As Long 'déclare la variable J (incrément)
Dim M As Integer 'déclare la variable J (incrément)
Dim N As Integer 'déclare la variable J (incrément)
Dim PCV As Integer 'déclare la variable PCV (Première Colonne Vide)
Dim TV As Variant 'déclare la variable TV (Tableau des Valeurs)
Dim TD() As Variant 'déclare la variable TD (Tableau des Doublons)
Dim R As Range 'déclare la variable R (Recherche)
Dim TMP As Variant 'déclare la variable TMP (TeMPoraire)
Dim PAS As Range 'déclare la variable PAS (Plage à Supprimer))

Application.ScreenUpdating = False 'masque les rafraîchissements d'écran
DEB = Timer 'début du chronométarge

'onglet "Base de données originales" (les dates sont en colonne 4 (= D)
Set OB = Worksheets("Base de données originales") 'définit l'onglet OB
Set D = CreateObject("Scripting.Dictionary") 'définit le dictionnaire D
Set PAS = OB.Range("A1") 'initialise la plage à supprimer PAS
DL = OB.Cells(Application.Rows.Count, "A").End(xlUp).Row 'définit la dernière ligne éditée DL de la colonne A de l'onglet OB
Set PL = OB.Range("A1:Q" & DL) 'définit la plage PL
Set PC = OB.Range("A1:A" & DL) 'définit la plage PL (la première colonne de PL)
TV = PL 'définit le tableau de valeurs TV
For I = DL To 2 Step -1 'boucle inversée sur toutes les lignes I du tableau des valeurs TV (de DL à 2)
    If D.exists(TV(I, 1)) Then GoTo suite 'si la donnée ligne I colonne 1 de TV existe dans le dictionnaire D, va à l'étiquette "suite"
    D(TV(I, 1)) = "" 'ajoute la donnée ligne I colonne 1 de TV au dictionnaire D
    K = 0 'initialise K
    If Application.WorksheetFunction.CountIf(PC, TV(I, 1)) > 1 Then 'condition 1 : si le nombre de fois que la donnée ligne I colonne 1 de TV existe dans la plage PC est supérieur à 1
        K = K + 1 'incrémente K
        ReDim Preserve TD(1 To 2, 1 To K) 'redimensionne le tableau des doublons TD (2 lignes, K colonnes)
        TD(1, K) = I 'récupère le numéro de ligne I dans la ligne de TD
        TD(2, K) = CLng(DateSerial(Year(TV(I, 4)), Month(TV(I, 4)), Day(TV(I, 4)))) 'récupère la date (en entier long) de la donnée ligne I colonne 4 de TV dans la ligne 2 de TD
        Set R = PC.Find(TV(I, 1), OB.Cells(I, 1), , , , xlPrevious, xlValues, xlWhole) 'définit la recherche R (Recherche au-dessous un nouvelle occurrence exacte de la données ligne I colonne 1de TV dans la plage PC)
        Do 'exécute
            K = K + 1 ' incrémente K
            ReDim Preserve TD(1 To 2, 1 To K)
            TD(1, K) = R.Row 'récupère le numéro de ligne de la l'occurrence trouvée dans la ligne de TD
            TD(2, K) = CLng(DateSerial(Year(PC(R.Row, 4).Value), Month(PC(R.Row, 4).Value), Day(PC(R.Row, 4).Value))) 'récupère la date (en entier long) de l'occurrence trouvée dans la ligne 2 de TD
            Set R = PC.FindPrevious(R) 'redéfinit la recherche R (occurrence précédente)
        Loop While Not R Is Nothing And R.Row <> I 'boucle tant qu'il existe des occurrence ailleurs que dans la ligne I
        'tri selon des dates
        For M = 1 To K 'boucle 1 : sur toutes les valeur du tableau des doublons (de 1 à K)
            For N = 1 To K 'boucle 2 : sur tous les doublons du tableau TD ( de 1 à K)
                If M <> N And TD(2, N) < TD(2, M) Then 'condition 2 : si M est différent de N est les dates sont identiques
                    TMP = TD(1, M): TD(1, M) = TD(1, N): TD(1, N) = TMP 'tri les numéro de lignes
                    TMP = TD(2, M): TD(2, M) = TD(2, N): TD(2, N) = TMP 'tri les dates
                End If 'fin de la contition 2
            Next N 'prochaine valeur N
        Next M 'prochaine valeur M
        'le tableau des doublons TD est maintenant trié de la date la plus récente à la date la plus ancienne
        For M = 2 To K 'boucle sur toutes les valeurs du tableau des doublons (en partant de la seconde, de 2 à K)
            PCV = OB.Cells(TD(1, 1), Application.Columns.Count).End(xlToLeft).Column + 1 'définit la première colonne vide PCV de la ligne la plus ancienne
            OB.Cells(TD(1, M), "A").Resize(1, 17).Copy OB.Cells(TD(1, 1), PCV) 'copy la cellule ligne TD(1,M) colonne A redimensionné de 17 colonne (soit la plage A:Q de la ligne TD(1,M)) dans le celllule ligne I colonne PCV
            Set PAS = IIf(PAS.Cells.Count = 1, OB.Rows(TD(1, M)), Application.Union(PAS, OB.Rows(TD(1, M)))) 'redéfinit la plage à supprimer PAS
        Next M 'prochain valeur de la boucle
    End If 'fin de la condition 1
suite: 'étiquette
Next I 'prochaine ligne de la boucle 1 (en remontant)
PAS.Delete 'supprime la plage PAS

'tous les autres onglets (les dates sont en colonne 5 (= E)
For Each OB In Sheets 'boucle : sur tous les onglets du classeur
    If OB.Name <> "Base de données originales" Then 'condition : si l'onglet ne se nomme pas "Base de données originales"
        Set D = CreateObject("Scripting.Dictionary")
        Set PAS = OB.Range("A1")
        DL = OB.Cells(Application.Rows.Count, "A").End(xlUp).Row
        Set PL = OB.Range("A1:Q" & DL)
        Set PC = OB.Range("A1:A" & DL)
        TV = PL
        For I = DL To 2 Step -1
            If D.exists(TV(I, 1)) Then GoTo suite2
            D(TV(I, 1)) = ""
            K = 0
            If Application.WorksheetFunction.CountIf(PC, TV(I, 1)) > 1 Then
                K = K + 1
                ReDim Preserve TD(1 To 2, 1 To K)
                TD(1, K) = I
                TD(2, K) = CLng(DateSerial(Year(TV(I, 5)), Month(TV(I, 5)), Day(TV(I, 5))))
                Set R = PC.Find(TV(I, 1), OB.Cells(I, 1), , , , xlPrevious, xlValues, xlWhole)
                Do
                    K = K + 1
                    ReDim Preserve TD(1 To 2, 1 To K)
                    TD(1, K) = R.Row
                    TD(2, K) = CLng(DateSerial(Year(PC(R.Row, 5).Value), Month(PC(R.Row, 5).Value), Day(PC(R.Row, 5).Value)))
                    Set R = PC.FindPrevious(R)
                Loop While Not R Is Nothing And R.Row <> I
                For M = 1 To K
                    For N = 1 To K
                        If M <> N And TD(2, N) < TD(2, M) Then
                            TMP = TD(1, M): TD(1, M) = TD(1, N): TD(1, N) = TMP
                            TMP = TD(2, M): TD(2, M) = TD(2, N): TD(2, N) = TMP
                        End If
                    Next N
                Next M
                For M = 2 To K
                    PCV = OB.Cells(TD(1, 1), Application.Columns.Count).End(xlToLeft).Column + 1 'définit la première colonne vide PCV de la ligne la plus ancienne
                    OB.Cells(TD(1, M), "A").Resize(1, 17).Copy OB.Cells(TD(1, 1), PCV) 'copy la cellule ligne J colonne A redimensionné de 17 colonne (soit la plage A:Q de la ligne J) dans le celllule ligne I colonne PCV
                    Set PAS = IIf(PAS.Cells.Count = 1, OB.Rows(TD(1, M)), Application.Union(PAS, OB.Rows(TD(1, M))))
                Next M
            End If
suite2:
        Next I
        PAS.Delete
    End If 'fin de la condition
Next OB 'prochain onglet de la boucle

Application.ScreenUpdating = True 'affiche les rafraîchissements d'écran
MsgBox "Données traitées  en " & Timer - DEB & " !" 'message
End Sub
Cliquez pour agrandir...
Bonjour Robert,

Merci pour ta disponibilité. En fait, comme je l'avais dit dans mon précédent message, le tri des dates, c'est la ligne ayant la plus ancienne date qui doit se trouver à gauche et à droite les plus récentes: (l'inverse de ce qui est actuellement. Aussi, l'onglet "base de donnees originale" n'est pas a considérer mais plutôt les autres.
Grand Merci pour l'aide que vous m'avez apporté.
 
Vote positif 0 Vote négatif
Robert

Robert

XLDnaute Barbatruc
Repose en paix
Bonjour le fil, bonjour le forum,

Pour l'onglet base de donnees originale tu aurais pu le dire plus tôt... Sinon il suffit d'inversé < et > dans le tri des doublons :
Code: 
Sub Macro1()
Dim DEB As Double ' déclare la variable DEB (DÉBut)
Dim OB As Worksheet 'déclare la variable OB (Onglet Base)
Dim D As Object 'déclare la variable D (Dictionnaire)
Dim DL As Integer 'déclare la variable DL (Dernière Ligne)
Dim PL As Range 'déclare la variable PL (PLage)
Dim PC As Range 'déclare la variable PL (Première Colonne)
Dim I As Long 'déclare la variable I (Incrément)
Dim J As Long 'déclare la variable J (incrément)
Dim K As Long 'déclare la variable J (incrément)
Dim M As Integer 'déclare la variable J (incrément)
Dim N As Integer 'déclare la variable J (incrément)
Dim PCV As Integer 'déclare la variable PCV (Première Colonne Vide)
Dim TV As Variant 'déclare la variable TV (Tableau des Valeurs)
Dim TD() As Variant 'déclare la variable TD (Tableau des Doublons)
Dim R As Range 'déclare la variable R (Recherche)
Dim TMP As Variant 'déclare la variable TMP (TeMPoraire)
Dim PAS As Range 'déclare la variable PAS (Plage à Supprimer))

Application.ScreenUpdating = False 'masque les rafraîchissements d'écran
DEB = Timer 'début du chronométarge
For Each OB In Sheets 'boucle : sur tous les onglets du classeur
    If OB.Name <> "Base de données originales" Then 'condition : si l'onglet ne se nomme pas "Base de données originales"
        Set D = CreateObject("Scripting.Dictionary")
        Set PAS = OB.Range("A1")
        DL = OB.Cells(Application.Rows.Count, "A").End(xlUp).Row
        Set PL = OB.Range("A1:Q" & DL)
        Set PC = OB.Range("A1:A" & DL)
        TV = PL
        For I = DL To 2 Step -1
            If D.exists(TV(I, 1)) Then GoTo suite2
            D(TV(I, 1)) = ""
            K = 0
            If Application.WorksheetFunction.CountIf(PC, TV(I, 1)) > 1 Then
                K = K + 1
                ReDim Preserve TD(1 To 2, 1 To K)
                TD(1, K) = I
                TD(2, K) = CLng(DateSerial(Year(TV(I, 5)), Month(TV(I, 5)), Day(TV(I, 5))))
                Set R = PC.Find(TV(I, 1), OB.Cells(I, 1), , , , xlPrevious, xlValues, xlWhole)
                Do
                    K = K + 1
                    ReDim Preserve TD(1 To 2, 1 To K)
                    TD(1, K) = R.Row
                    TD(2, K) = CLng(DateSerial(Year(PC(R.Row, 5).Value), Month(PC(R.Row, 5).Value), Day(PC(R.Row, 5).Value)))
                    Set R = PC.FindPrevious(R)
                Loop While Not R Is Nothing And R.Row <> I
                For M = 1 To K
                    For N = 1 To K
                        If M <> N And TD(2, N) > TD(2, M) Then '<===== ici le changement
                            TMP = TD(1, M): TD(1, M) = TD(1, N): TD(1, N) = TMP
                            TMP = TD(2, M): TD(2, M) = TD(2, N): TD(2, N) = TMP
                        End If
                    Next N
                Next M
                For M = 2 To K
                    PCV = OB.Cells(TD(1, 1), Application.Columns.Count).End(xlToLeft).Column + 1 'définit la première colonne vide PCV de la ligne la plus ancienne
                    OB.Cells(TD(1, M), "A").Resize(1, 17).Copy OB.Cells(TD(1, 1), PCV) 'copy la cellule ligne J colonne A redimensionné de 17 colonne (soit la plage A:Q de la ligne J) dans le celllule ligne I colonne PCV
                    Set PAS = IIf(PAS.Cells.Count = 1, OB.Rows(TD(1, M)), Application.Union(PAS, OB.Rows(TD(1, M))))
                Next M
            End If
suite2:
        Next I
        PAS.Delete
    End If 'fin de la condition
Next OB 'prochain onglet de la boucle
Application.ScreenUpdating = True 'affiche les rafraîchissements d'écran
MsgBox "Données traitées  en " & Timer - DEB & " !" 'message
End Sub
 
Vote positif 0 Vote négatif
K

karamoko512

XLDnaute Nouveau
Robert à dit:
Bonjour le fil, bonjour le forum,

Pour l'onglet base de donnees originale tu aurais pu le dire plus tôt... Sinon il suffit d'inversé < et > dans le tri des doublons :
Code: 
Sub Macro1()
Dim DEB As Double ' déclare la variable DEB (DÉBut)
Dim OB As Worksheet 'déclare la variable OB (Onglet Base)
Dim D As Object 'déclare la variable D (Dictionnaire)
Dim DL As Integer 'déclare la variable DL (Dernière Ligne)
Dim PL As Range 'déclare la variable PL (PLage)
Dim PC As Range 'déclare la variable PL (Première Colonne)
Dim I As Long 'déclare la variable I (Incrément)
Dim J As Long 'déclare la variable J (incrément)
Dim K As Long 'déclare la variable J (incrément)
Dim M As Integer 'déclare la variable J (incrément)
Dim N As Integer 'déclare la variable J (incrément)
Dim PCV As Integer 'déclare la variable PCV (Première Colonne Vide)
Dim TV As Variant 'déclare la variable TV (Tableau des Valeurs)
Dim TD() As Variant 'déclare la variable TD (Tableau des Doublons)
Dim R As Range 'déclare la variable R (Recherche)
Dim TMP As Variant 'déclare la variable TMP (TeMPoraire)
Dim PAS As Range 'déclare la variable PAS (Plage à Supprimer))

Application.ScreenUpdating = False 'masque les rafraîchissements d'écran
DEB = Timer 'début du chronométarge
For Each OB In Sheets 'boucle : sur tous les onglets du classeur
    If OB.Name <> "Base de données originales" Then 'condition : si l'onglet ne se nomme pas "Base de données originales"
        Set D = CreateObject("Scripting.Dictionary")
        Set PAS = OB.Range("A1")
        DL = OB.Cells(Application.Rows.Count, "A").End(xlUp).Row
        Set PL = OB.Range("A1:Q" & DL)
        Set PC = OB.Range("A1:A" & DL)
        TV = PL
        For I = DL To 2 Step -1
            If D.exists(TV(I, 1)) Then GoTo suite2
            D(TV(I, 1)) = ""
            K = 0
            If Application.WorksheetFunction.CountIf(PC, TV(I, 1)) > 1 Then
                K = K + 1
                ReDim Preserve TD(1 To 2, 1 To K)
                TD(1, K) = I
                TD(2, K) = CLng(DateSerial(Year(TV(I, 5)), Month(TV(I, 5)), Day(TV(I, 5))))
                Set R = PC.Find(TV(I, 1), OB.Cells(I, 1), , , , xlPrevious, xlValues, xlWhole)
                Do
                    K = K + 1
                    ReDim Preserve TD(1 To 2, 1 To K)
                    TD(1, K) = R.Row
                    TD(2, K) = CLng(DateSerial(Year(PC(R.Row, 5).Value), Month(PC(R.Row, 5).Value), Day(PC(R.Row, 5).Value)))
                    Set R = PC.FindPrevious(R)
                Loop While Not R Is Nothing And R.Row <> I
                For M = 1 To K
                    For N = 1 To K
                        If M <> N And TD(2, N) > TD(2, M) Then '<===== ici le changement
                            TMP = TD(1, M): TD(1, M) = TD(1, N): TD(1, N) = TMP
                            TMP = TD(2, M): TD(2, M) = TD(2, N): TD(2, N) = TMP
                        End If
                    Next N
                Next M
                For M = 2 To K
                    PCV = OB.Cells(TD(1, 1), Application.Columns.Count).End(xlToLeft).Column + 1 'définit la première colonne vide PCV de la ligne la plus ancienne
                    OB.Cells(TD(1, M), "A").Resize(1, 17).Copy OB.Cells(TD(1, 1), PCV) 'copy la cellule ligne J colonne A redimensionné de 17 colonne (soit la plage A:Q de la ligne J) dans le celllule ligne I colonne PCV
                    Set PAS = IIf(PAS.Cells.Count = 1, OB.Rows(TD(1, M)), Application.Union(PAS, OB.Rows(TD(1, M))))
                Next M
            End If
suite2:
        Next I
        PAS.Delete
    End If 'fin de la condition
Next OB 'prochain onglet de la boucle
Application.ScreenUpdating = True 'affiche les rafraîchissements d'écran
MsgBox "Données traitées  en " & Timer - DEB & " !" 'message
End Sub
Cliquez pour agrandir...
Bonjour Robert,
Merci infiniment. ça fonctionne parfaitement. Merci
Karamoko512
 
Vote positif 0 Vote négatif

Discussions similaires

F
  • Résolu(e)
XL 2021 recherche doublons dans colonne puis suppression des lignes
Réponses
5
Affichages
170
ftpo69
F
P
  • Résolu(e)
Microsoft 365 Crée un VBA pour repérer des doublons sur un tableur excel
2 3
Réponses
31
Affichages
2 K
patrick965
P
N
  • Résolu(e)
Microsoft 365 Rechercher doublons dans une plage de cellule
Réponses
5
Affichages
390
chris
chris
I
  • Question
Microsoft 365 Déplacer la ligne visible après le filtre
Réponses
3
Affichages
269
iliess
I
T
  • Question
Microsoft 365 Supprimer les lignes en doublon
2
Réponses
26
Affichages
856
Cousinhub
Cousinhub
E
  • Résolu(e)
Microsoft 365 Boucle sur lignes <>0
Réponses
2
Affichages
143
eric72
E
R
  • Question
XL 2010 Sélectionner une plage selon contenu d'une colonne
Réponses
2
Affichages
250
Romain31
R
T
  • Question
XL 2016 SI INDEX EQUIV Doublons...
Réponses
8
Affichages
167
Titiem
T
M
  • Question
XL 2021 Rechercher dans une matrice le texte d'une cellule et copier les 10 lignes situées en dessous de ce texte retrouvé
Réponses
2
Affichages
132
JHA
J
B
  • Question
Microsoft 365 Erreur de compilation
Réponses
3
Affichages
511
oguruma
oguruma

Membres actuellement en ligne

14 membres et 106 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
312 163
Messages
2 085 861
Membres
103 006
dernier inscrit
blkevin