XL pour MAC Contrôle doublons & supprimer la (les) ligne (s) saisie (s) deux fois

luno123 · 14 Mai 2021

Bonjour,

J'alimente toutes les semaines l'onglet "contrôle rglmt factor" sans forcément savoir si j'ai repris des écritures des semaines précédentes.
Pour m'assurer de ne pas avoir de doublons, je suis obligé de vérifier manuellement ligne par ligne.
Je souhaiterais un contrôle rapide (via une macro par exemple) qui permettrait de ressortir tous les doublons selon certaines conditions:
1. Si deux "montant règlement" sont identiques;
2. Vérifier s'ils ont le même "nom acheteur" et même "nature règlement"
3. Ensuite vérifier s'ils ont le même "code client" et/ou même "observation sur règlement" (car des fois le code client est renseigné dans la colonne ""observation sur règlement")
Si ces trois conditions sont remplies, donner un lettrage identique (qui se créerait dans la nouvelle colonne H "à vérifier", qui permettrait de les afficher l'une après l'autre, afin de pouvoir en supprimer celle de trop.

Merci d'avance pour votre aide

Luno

sylvanu · 14 Mai 2021

Bonjour Luno,
Vous auriez du mettre quelques exemples de doublons pour vérification. J'en ai rajouté quelques uns à la fin.
Dans la colonne H j'ai mis des numéros de doublons, il suffit alors de filtrer pour voir les doublons N°1, doublons N°2 ...

VB:

Sub Vérifie()
    Dim DL%, L1%, L2%, Doublon%, Trouvé%
    Application.ScreenUpdating = False
    DL = Range("A65500").End(xlUp).Row
    Range("H2:H" & DL).ClearContents
    Doublon = 1
    For L1 = 2 To DL
        Trouvé = 0
        For L2 = L1 + 1 To DL
            If Cells(L2, "C") = Cells(L1, "C") Then             ' Meme montant
                If Cells(L2, "B") = Cells(L1, "B") Then         ' Meme acheteur
                    If Cells(L2, "F") = Cells(L1, "F") Then     ' Même code client
                        If Cells(L2, "D") = Cells(L1, "D") And Cells(L2, "E") = Cells(L1, "E") Then  ' Même Obs et Nature
                            If Cells(L2, "H") = "" Then
                                Cells(L1, "H") = Doublon: Cells(L2, "H") = Doublon: Trouvé = 1
                            End If
                        End If
                    End If
                End If
            End If
        Next L2
        If Trouvé = 1 Then Doublon = Doublon + 1
    Next L1
End Sub

luno123 · 16 Mai 2021

sylvanu à dit:

Bonjour Luno,
Vous auriez du mettre quelques exemples de doublons pour vérification. J'en ai rajouté quelques uns à la fin.
Dans la colonne H j'ai mis des numéros de doublons, il suffit alors de filtrer pour voir les doublons N°1, doublons N°2 ...

VB:

Sub Vérifie()
    Dim DL%, L1%, L2%, Doublon%, Trouvé%
    Application.ScreenUpdating = False
    DL = Range("A65500").End(xlUp).Row
    Range("H2:H" & DL).ClearContents
    Doublon = 1
    For L1 = 2 To DL
        Trouvé = 0
        For L2 = L1 + 1 To DL
            If Cells(L2, "C") = Cells(L1, "C") Then             ' Meme montant
                If Cells(L2, "B") = Cells(L1, "B") Then         ' Meme acheteur
                    If Cells(L2, "F") = Cells(L1, "F") Then     ' Même code client
                        If Cells(L2, "D") = Cells(L1, "D") And Cells(L2, "E") = Cells(L1, "E") Then  ' Même Obs et Nature
                            If Cells(L2, "H") = "" Then
                                Cells(L1, "H") = Doublon: Cells(L2, "H") = Doublon: Trouvé = 1
                            End If
                        End If
                    End If
                End If
            End If
        Next L2
        If Trouvé = 1 Then Doublon = Doublon + 1
    Next L1
End Sub

Bonjour Sylvanu,

C'est bizarre mais je viens juste de voir votre réponse. Vous avez tout à fait raison, j'aurais du mettre des exempleS de doublons. et ce n'est pas faute d'y avoir songé. Cependant des fois à force de donner des exemples, on finit par rendre incompréhensible la demande. Mais j'ai eu tort.
Sinon merci beaucoup pour le retour. Je fais le test sur mon fichier et vous fais un retour.
Good job.

luno123 · 17 Mai 2021

Bonsoir Sylvanu, bonsoir le forum,

J'ai pu tester le fichier qui répond exactement à ma demande. J'en rajouterai même un autre (ok j'abuse de votre gentillesse): serait-il possible de faire de sorte que:
- la mise en forme (selon fichier joint) se fasse automatiquement en fonction du nombre de lignes rajouté?
- je puisse remettre la colonne H " à vérifier à zéro" ?

Merci d'avance

sylvanu · 18 Mai 2021

Bonjour Luno,
J'avoue ne pas comprendre.
1- Si vous rajoutez des lignes la mise en forme est respectée puisqu'il s'agit d'un tableau structuré.
2- Remettre à 0 la colonne H ? Mais le but de la macro est justement de remplir la colonne H avec des doublons. Vous désirez un bouton "Efface H" ?

luno123 · 18 Mai 2021

sylvanu à dit:
Bonjour Luno,
J'avoue ne pas comprendre.
1- Si vous rajoutez des lignes la mise en forme est respectée puisqu'il s'agit d'un tableau structuré.
2- Remettre à 0 la colonne H ? Mais le but de la macro est justement de remplir la colonne H avec des doublons. Vous désirez un bouton "Efface H" ?

Bonjour,

Si je ne me trompe pas la mise en forme ne se fait pas automatiquement. J’ai joint le dernier fichier que j’avais retravaillé avec la mise en forme souhaitée. Je m’explique : je souhaiterai que la mise en forme s’adapte et se limite à la dernière ligne saisie. Peut être il faudrait un bouton à part « MEF » ?

Pour la colonne H ; oui l’objectif est de la remplir. Cependant, pour des raisons différentes, je peux être amené à vouloir (ou devoir) la remettre à zéro avant de relancer la macro. Maintenant si c’est trop compliqué, je le ferai manuellement.

Je ne sais pas si j’ai été plus explicite cette fois-ci ?

Merci d’avance.

Luno

job75 · 18 Mai 2021

Bonjour luno123, sylvanu,

Une solution par formules dans le fichier joint.

La colonne Concat concatène les colonnes Montant du règlement, Nature du règlement, Code client.

Ne pas utiliser le nom de l'acheteur car il peut y avoir des fautes d'orthographe.

Evidemment s'il y a beaucoup de lignes le calcul prendra du temps, il faudra du VBA.

Pour la mise en forme je vois luno123 que vous ne savez pas ce qu'est un tableau Excel structuré.

A+

luno123 · 18 Mai 2021

sylvanu à dit:
Bonjour Luno,
J'avoue ne pas comprendre.
1- Si vous rajoutez des lignes la mise en forme est respectée puisqu'il s'agit d'un tableau structuré.
2- Remettre à 0 la colonne H ? Mais le but de la macro est justement de remplir la colonne H avec des doublons. Vous désirez un bouton "Efface H" ?

Sylvau,

Je pense qu'il serait plus judicieux d'analyser que les montants.
En fait, en cas d'erreur de frappe par le factor ou d'erreur sur le compte d'imputation, la macro ne détectera pas l'anomalie. donc les colonnes B F D E ne devraient pas être analysées.
If Cells(L2, "B") = Cells(L1, "B") Then ' Meme acheteur
If Cells(L2, "F") = Cells(L1, "F") Then ' Même code client
If Cells(L2, "D") = Cells(L1, "D") And Cells(L2, "E") = Cells(L1, "E") Then ' Même Obs et Nature

J'ai modifié la macro pour qu'elle ne prenne que la colonne montant. Vous trouverez en pj mrd modif.

Merci d'avance

job75 · 18 Mai 2021

Avec un grand tableau on utilisera cette macro évènementielle qui fait la même chose que les formules :

VB:

Private Sub Worksheet_Change(ByVal Target As Range)
Dim d As Object, dd As Object, decal&, tablo, resu(), i&, x$
Set d = CreateObject("Scripting.Dictionary")
d.CompareMode = vbTextCompare 'la casse est ignorée
Set dd = CreateObject("Scripting.Dictionary")
dd.CompareMode = vbTextCompare 'la casse est ignorée
With ListObjects(1).Range 'tableau structuré
    decal = .Row - 1
    tablo = .Resize(, 6)
    ReDim resu(1 To UBound(tablo), 1 To 1)
    For i = 2 To UBound(tablo)
        x = tablo(i, 3) & tablo(i, 4) & tablo(i, 6)
        If x <> "" Then d(x) = d(x) + 1 'comptage
    Next i
    For i = 2 To UBound(tablo)
        x = tablo(i, 3) & tablo(i, 4) & tablo(i, 6)
        If d(x) > 1 Then
            If Not dd.exists(x) Then dd(x) = i + decal 'mémorise le numéro de ligne
            resu(i, 1) = dd(x)
        End If
    Next i
    resu(1, 1) = .Cells(1, 8)
    Application.EnableEvents = False 'désactive les évènements
    .Columns(8) = resu 'restitution
    Application.EnableEvents = True 'réactive les évènements
End With
End Sub

Elle se déclenche quand on modifie ou valide une cellule quelconque.

Elle est très rapide car elle utilise des tableaux VBA et 2 Dictionary.

luno123 · 18 Mai 2021

job75 à dit:

Avec un grand tableau on utilisera cette macro évènementielle qui fait la même chose que les formules :

VB:

Private Sub Worksheet_Change(ByVal Target As Range)
Dim d As Object, dd As Object, decal&, tablo, resu(), i&, x$
Set d = CreateObject("Scripting.Dictionary")
d.CompareMode = vbTextCompare 'la casse est ignorée
Set dd = CreateObject("Scripting.Dictionary")
dd.CompareMode = vbTextCompare 'la casse est ignorée
With ListObjects(1).Range 'tableau structuré
    decal = .Row - 1
    tablo = .Resize(, 6)
    ReDim resu(1 To UBound(tablo), 1 To 1)
    For i = 2 To UBound(tablo)
        x = tablo(i, 3) & tablo(i, 4) & tablo(i, 6)
        If x <> "" Then d(x) = d(x) + 1 'comptage
    Next i
    For i = 2 To UBound(tablo)
        x = tablo(i, 3) & tablo(i, 4) & tablo(i, 6)
        If i = 11 Then MsgBox IsEmpty(d(x))
        If d(x) > 1 Then
            If Not dd.exists(x) Then dd(x) = i + decal 'mémorise le numéro de ligne
            resu(i, 1) = dd(x)
        End If
    Next i
    resu(1, 1) = .Cells(1, 8)
    Application.EnableEvents = False 'désactive les évènements
    .Columns(8) = resu 'restitution
    Application.EnableEvents = True 'réactive les évènements
End With
End Sub

Elle se déclenche quand on modifie ou valide une cellule quelconque.

Elle est très rapide car elle utilise des tableaux VBA et 2 Dictionary.

Bonjur Job,

Merci pour votre retour. Cependant une erreur quand je copie et colle une ligne
En jaune:
Set d = CreateObject("Scripting.Dictionary")

job75 · 18 Mai 2021

Ah oui j'oubliais que vous êtes sur MAC, les Dictionary ne sont pas acceptés, il faut utiliser des collections

job75 · 18 Mai 2021

Voici le code qui va bien sur MAC, fichier (2) :

VB:

Option Compare Text 'la casse est ignorée

Private Sub Worksheet_Change(ByVal Target As Range)
Dim col As New Collection, decal&, tablo, resu(), i&, x$, n&
On Error Resume Next
With ListObjects(1).Range 'tableau structuré
    decal = .Row - 1
    tablo = .Resize(, 6)
    ReDim resu(1 To UBound(tablo), 1 To 1)
    For i = 2 To UBound(tablo)
        x = tablo(i, 3) & tablo(i, 4) & tablo(i, 6)
        If x <> "" Then
            col.Add i + decal, x 'mémorise la ligne
            n = col(x): resu(n, 1) = resu(n, 1) + 1 'comptage
            resu(i, 1) = resu(n, 1)
        End If
    Next i
    For i = 2 To UBound(resu)
        x = tablo(i, 3) & tablo(i, 4) & tablo(i, 6)
        If resu(i, 1) > 1 Then resu(i, 1) = col(x) Else resu(i, 1) = Empty
    Next i
    resu(1, 1) = .Cells(1, 8)
    Application.EnableEvents = False 'désactive les évènements
    .Columns(8) = resu 'restitution
    Application.EnableEvents = True 'réactive les évènements
End With
End Sub

job75 · 18 Mai 2021

J'ai testé les macros sur 90 000 lignes :

- fichier (1) avec les 2 Dictionary => 0,81 seconde

- fichier (2) avec la collection => 0,48 seconde.

Pourtant en général le Dictionary est plus rapide, je vais voir pourquoi il l'est moins.

job75 · 18 Mai 2021

Dans ce fichier (1 bis) j'ai revu la macro du post #9 pour n'utiliser qu'un seul Dictionary :

VB:

Private Sub Worksheet_Change(ByVal Target As Range)
Dim d As Object, decal&, tablo, resu(), i&, x$, n&
Set d = CreateObject("Scripting.Dictionary")
d.CompareMode = vbTextCompare 'la casse est ignorée
With ListObjects(1).Range 'tableau structuré
    decal = .Row - 1
    tablo = .Resize(, 6)
    ReDim resu(1 To UBound(tablo), 1 To 1)
    For i = 2 To UBound(tablo)
        x = tablo(i, 3) & tablo(i, 4) & tablo(i, 6)
        If x <> "" Then
            If Not d.exists(x) Then d(x) = i + decal 'mémorise la ligne
            n = d(x): resu(n, 1) = resu(n, 1) + 1 'comptage
            resu(i, 1) = resu(n, 1)
        End If
    Next i
    For i = 2 To UBound(resu)
        If resu(i, 1) > 1 Then resu(i, 1) = d(tablo(i, 3) & tablo(i, 4) & tablo(i, 6)) Else resu(i, 1) = ""
    Next i
    resu(1, 1) = .Cells(1, 8)
    Application.EnableEvents = False 'désactive les évènements
    .Columns(8) = resu 'restitution
    Application.EnableEvents = True 'réactive les évènements
End With
End Sub

Sur 90 000 lignes elle s'exécute en 0,67 seconde, encore un peu moins rapide que le fichier (2)...

XL pour MAC Contrôle doublons & supprimer la (les) ligne (s) saisie (s) deux fois

luno123

XLDnaute Occasionnel

Pièces jointes

sylvanu

XLDnaute Barbatruc

Pièces jointes

luno123

XLDnaute Occasionnel

luno123

XLDnaute Occasionnel

Pièces jointes

sylvanu

XLDnaute Barbatruc

luno123

XLDnaute Occasionnel

job75

XLDnaute Barbatruc

Pièces jointes

luno123

XLDnaute Occasionnel

Pièces jointes

job75

XLDnaute Barbatruc

Pièces jointes

luno123

XLDnaute Occasionnel

job75

XLDnaute Barbatruc

job75

XLDnaute Barbatruc

Pièces jointes

job75

XLDnaute Barbatruc

job75

XLDnaute Barbatruc

Pièces jointes

Discussions similaires