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

luno123

XLDnaute Occasionnel
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
 

Pièces jointes

  • Controle rglmt factor.xls
    35.5 KB · Affichages: 19
Dernière édition:

sylvanu

XLDnaute Barbatruc
Supporter XLD
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
 

Pièces jointes

  • Controle rglmt factor.xlsm
    21.3 KB · Affichages: 11

luno123

XLDnaute Occasionnel
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

XLDnaute Occasionnel
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
 

Pièces jointes

  • Controle rglmt factor-1.xlsm
    19.9 KB · Affichages: 3

sylvanu

XLDnaute Barbatruc
Supporter XLD
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

XLDnaute Occasionnel
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

XLDnaute Barbatruc
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+
 

Pièces jointes

  • Controle rglmt factor(1).xlsx
    13.9 KB · Affichages: 2

luno123

XLDnaute Occasionnel
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
 

Pièces jointes

  • Controle rglmt factor-1.xlsm
    20 KB · Affichages: 1
Dernière édition:

job75

XLDnaute Barbatruc
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.
 

Pièces jointes

  • Controle rglmt VBA(1).xlsm
    20.9 KB · Affichages: 4
Dernière édition:

luno123

XLDnaute Occasionnel
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

XLDnaute Barbatruc
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
 

Pièces jointes

  • Controle rglmt VBA(2).xlsm
    21.2 KB · Affichages: 2
Dernière édition:

job75

XLDnaute Barbatruc
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.
 
Dernière édition:

job75

XLDnaute Barbatruc
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)...
 

Pièces jointes

  • Controle rglmt VBA(1 bis).xlsm
    21.2 KB · Affichages: 3

Discussions similaires

Statistiques des forums

Discussions
311 720
Messages
2 081 900
Membres
101 834
dernier inscrit
Jeremy06510