XL 2013 macro recherche doublon

Jacques25

XLDnaute Occasionnel
Bonjour à tous,

J'essaye de construire un code pour rechercher des doublons, je pense savoir comment faire mais au niveau de la syntaxe comme d'habitude je coince.

En clair j'ai scinder le contenu de ma colonne A pour avoir un mot par cellule entre la colonne B et G avec le code suivant :

For i = 1 To 1597
t1 = Split(Cells(i, 1), " ")
For y = 0 To UBound(t1)
Cells(i, y + 2) = t1(y)
Next y
Next i

Ca c'est OK maintenant je voudrais comparer le contenu de mes cellules B2 à G1597 entre elles pour trouver d'éventuels doublons et indiquer ou est le doublon
si B2 = F847 on inscrit en I2 F847 ou les coordonnées de la cellule si c'est plus simple genre 847,6
Si G8 = D15 on inscrit en N8 D15 ou 15,4

Je vous joins un fichier exemple pour une meilleur compréhension.

Merci d'avance de votre aide
@ plus

Bonne journée
Jack
 

Pièces jointes

  • essai doublon.xlsm
    15.4 KB · Affichages: 38

Lolote83

XLDnaute Barbatruc
Bonjour,
Est ce qu'une simple MFC te conviendrait ?
En B1=NB.SI($B$1:$G$11;B1)>1 et appliquer un fond de couleur comme le montre la copie d'écran

upload_2018-12-12_10-59-5.png

Sinon, je cherche une solution par macro
@+ Lolote83
 

Lolote83

XLDnaute Barbatruc
Re salut,
Comment faire afficher dans tes cellules de destination (exemple cellule I1 de ton classeur si 3 ou plus de TOTO et idem pour H3)
Actuellement, tu donnes un exemples avec seulement 2 TOTO (C1 et B3) donc retranscrit en I1 = B3 et H3 = C1.
Si il y a 3 ou plus de TOTO, comment veux tu écrires les données
@+ Lolote83
 

laurent950

XLDnaute Accro
Bonsoir,
J'ai fait un code qui peux être ajusté est bien construit, simplifié pour exemple :
- un Module standard
- Avec Variable Typé
- Appel à Module de classe (avec la feuille active implémenté dans le module de classe suite à cette appel)
- La variable typé pour les zones du range a traité se qui peux être ajustable en passant par celle-ci
- Refait la fonction de découpage dans le module de classe
- l'identification des doublons a retrouver en passant par des variables tableaux

Je joint le module standard = Main
et le module de classe = TrouveDoublon
et le fichier excel servant de modèle avec les codes joint

' Ici le Module standard = Main
VB:
Option Explicit
' Pour la zone a traiter
Type Plage
    LignDepart As Double
    LigneFin As Double
    ColoneDepart As Double
    ColoneFin As Double
End Type
Public Sub Doublon()
    Dim TabBase As TrouveDoublon
        Set TabBase = New TrouveDoublon
    ' Mise en mémoire de la Feuille active
        TabBase.FeuilActive
    ' Enregistre la zone
        ' Ligne 1 colone 1 à Ligne 5 colone 1
         Dim Zone As Plage
            Zone.LignDepart = 1
            Zone.LigneFin = 5
            Zone.ColoneDepart = 1
            Zone.ColoneFin = 1
    ' Decoupage de la zone
        TabBase.Separation Zone
    ' Trouve les doublons
     TabBase.TrouveDoublon Zone
End Sub

' Ici le Module de classe = TrouveDoublon
VB:
' Initialise les variables Tableaux à 1 pour Option Base 1
' Option Base 1
' Feuille active en Mémoire
Private mFactiv As Worksheet
Private Property Let TablDoublon(Zone As Plage)
    mPlage = Plage
End Property
Sub FeuilActive()
    Set mFactiv = Worksheets(ActiveSheet.Name)
End Sub
Sub Separation(Zone As Plage)
Dim i As Double
Dim y As Integer
For i = Zone.LignDepart To Zone.LigneFin
        t1 = Split(mFactiv.Cells(i, 1), " ")
            For y = 0 To UBound(t1)
                mFactiv.Cells(i, y + 2) = t1(y)
            Next y
Next i
i = Empty
y = Empty
End Sub
Sub TrouveDoublon(Zone As Plage)
Dim TabRemplis() As Variant
Dim cpt As Double
cpt = 0
ReDim TabRemplis(cpt)
Dim TabTrouv() As Variant
Dim i As Double
Dim j As Double
Dim y As Integer
    ' Remplis toutes les découpages dans une variable tableau 1 dimension
    For i = Zone.LignDepart To Zone.LigneFin
        t1 = Split(mFactiv.Cells(i, 1), " ")
            ' Remplis le tableau TabTrouv pour trouver les doublons !
            For j = LBound(t1) To UBound(t1)
                TabRemplis(cpt) = t1(j)
                cpt = cpt + 1
                ReDim Preserve TabRemplis(cpt)
            Next j
    Next i
    i = Empty
    j = Empty
    cpt = 0
    ReDim TabTrouv(cpt)
    ' Trouve les doublons !
    For i = LBound(TabRemplis) To UBound(TabRemplis)
        For j = i + 1 To UBound(TabRemplis)
                If TabRemplis(i) = TabRemplis(j) Then
                    TabTrouv(cpt) = TabRemplis(i)
                        cpt = cpt + 1
                    ReDim Preserve TabTrouv(cpt)
                End If
            Next j
    Next i
    i = Empty
    j = Empty
    cpt = 0
    ' Colle les élements dans la Feuilles comme demander en fonction de l'identification des doublons
    ' dans le tableau TabTrouv de la colone 2
    For i = Zone.LignDepart To Zone.LigneFin
        t1 = Split(mFactiv.Cells(i, 1), " ")
        For j = LBound(TabTrouv) To UBound(TabTrouv)
            For y = 0 To UBound(t1)
                If TabTrouv(j) = t1(y) Then
                    mFactiv.Cells(i, y + 8) = t1(y)
                End If
            Next y
        Next j
    Next i
    i = Empty
    j = Empty
    y = Empty
    Erase TabRemplis, TabTrouv
End Sub

Et le fichier excel : TrouveDoublonModuleClasse.xlsm

Laurent
 

Pièces jointes

  • TrouveDoublonModuleClasse.xlsm
    30.2 KB · Affichages: 40

laurent950

XLDnaute Accro
re,
J'ai identifier les mots en doublon dans la liste "couleur rouge en caractère gras"

' Module standard : Main
VB:
Option Explicit
' Pour la zone a traiter
Type Plage
    LignDepart As Double
    LigneFin As Double
    ColoneDepart As Double
    ColoneFin As Double
End Type
Public Sub Doublon()
    Dim TabBase As TrouveDoublon
        Set TabBase = New TrouveDoublon
    ' Mise en mémoire de la Feuille active
        TabBase.FeuilActive
    ' Enregistre la zone
        ' Ligne 1 colone 1 à Ligne 5 colone 1
         Dim Zone As Plage
            Zone.LignDepart = 1
            Zone.LigneFin = 5
            Zone.ColoneDepart = 1
            Zone.ColoneFin = 1
    ' Decoupage de la zone
        TabBase.Separation Zone
    ' Trouve les doublons
     TabBase.TrouveDoublon Zone
' *****************************************************************
    ' Identifie les mots qui sont en doublon
    Dim ColorTex As IdentifiText
    Set ColorTex = New IdentifiText
    ' coloriage du texte qui correspond au doublon
    Dim Doublon() As Variant
        Doublon = TabBase.TablIdentDoublon
    ColorTex.FeuilActive
    ColorTex.ColoriageText Doublon, Zone
End Sub

' Module de classe Modifier : TrouveDoublon
VB:
' Initialise les variables Tableaux à 1 pour Option Base 1
' Option Base 1
' Feuille active en Mémoire
Private mFactiv As Worksheet
Private mTabTrouv() As Variant
Public Property Get TablIdentDoublon() As Variant
    TablIdentDoublon = mTabTrouv
End Property
Private Property Let TablDoublon(Zone As Plage)
    mPlage = Plage
End Property
Sub FeuilActive()
    Set mFactiv = Worksheets(ActiveSheet.Name)
End Sub
Sub Separation(Zone As Plage)
Dim i As Double
Dim y As Integer
For i = Zone.LignDepart To Zone.LigneFin
        t1 = Split(mFactiv.Cells(i, 1), " ")
            For y = 0 To UBound(t1)
                mFactiv.Cells(i, y + 2) = t1(y)
            Next y
Next i
i = Empty
y = Empty
End Sub
Sub TrouveDoublon(Zone As Plage)
Dim TabRemplis() As Variant
Dim cpt As Double
cpt = 0
ReDim TabRemplis(cpt)
Dim TabTrouv() As Variant
Dim i As Double
Dim j As Double
Dim y As Integer
    ' Remplis toutes les découpages dans une variable tableau 1 dimension
    For i = Zone.LignDepart To Zone.LigneFin
        t1 = Split(mFactiv.Cells(i, 1), " ")
            ' Remplis le tableau TabTrouv pour trouver les doublons !
            For j = LBound(t1) To UBound(t1)
                TabRemplis(cpt) = t1(j)
                cpt = cpt + 1
                ReDim Preserve TabRemplis(cpt)
            Next j
    Next i
    i = Empty
    j = Empty
    cpt = 0
    ReDim TabTrouv(cpt)
    ' Trouve les doublons !
    For i = LBound(TabRemplis) To UBound(TabRemplis)
        For j = i + 1 To UBound(TabRemplis)
                If TabRemplis(i) = TabRemplis(j) Then
                    TabTrouv(cpt) = TabRemplis(i)
                        cpt = cpt + 1
                    ReDim Preserve TabTrouv(cpt)
                End If
            Next j
    Next i
    ReDim Preserve TabTrouv(cpt - 1)
    i = Empty
    j = Empty
    cpt = 0
    ' Colle les élements dans la Feuilles comme demander en fonction de l'identification des doublons
    ' dans le tableau TabTrouv de la colone 2
    For i = Zone.LignDepart To Zone.LigneFin
        t1 = Split(mFactiv.Cells(i, 1), " ")
        For j = LBound(TabTrouv) To UBound(TabTrouv)
            For y = 0 To UBound(t1)
                If TabTrouv(j) = t1(y) Then
                    mFactiv.Cells(i, y + 8) = t1(y)
                End If
            Next y
        Next j
    Next i
    i = Empty
    j = Empty
    y = Empty
    ' conserve les doublons trouvé dans une variable propre au module de classe
    mTabTrouv = TabTrouv
    Erase TabRemplis, TabTrouv
End Sub

' Module de classe : Identifie les partie texte en doublon colorier en gras couleur rouge
Ne pas Oublier de cocher
ExpressionReguliereRegex.jpg

' Pour Instancie les variables !
' Cocher la case à côté de "Microsoft VBScrit Regular Expressions 5.5" à inclure dans votre classeur.
' C'est dans la boite a Outils VBA
VB:
Private mFactiv As Worksheet
Sub FeuilActive()
    Set mFactiv = Worksheets(ActiveSheet.Name)
End Sub
Sub ColoriageText(Doublon() As Variant, Zone As Plage)
' https://cafeine.developpez.com/access/tutoriel/regexp/
'http://dedeuf.free.fr/Faq/php/exp_regulieres.htm
''''' http://www.loribel.com/info/memento/regex.html
' http://www.loribel.com/info/memento/regex.html
'https://www.lucaswillems.com/fr/articles/25/tutoriel-pour-maitriser-les-expressions-regulieres
' Trouve le Mot Exacte de la chaine !

'Il faut substitué cette ligne par cette ligne :
'qui fonctionne en local sur la feuille active.

'*** ------------------------------------------------------------------------------
' Instancie les variables !
' Cocher la case à côté de "Microsoft VBScrit Regular Expressions 5.5" à inclure dans votre classeur.
    Dim reg As VBScript_RegExp_55.RegExp
    Dim Match As VBScript_RegExp_55.Match
    Dim Matches As VBScript_RegExp_55.MatchCollection

'*** ------------------------------------------------------------------------------
' Tableaux des expression reguliéres !!
Tabqts = Doublon

' Phrase rechercher dans excel ici cellule B1!!
Dim Phrase As String
For Boucl = Zone.LignDepart To Zone.LigneFin
Phrase = mFactiv.Cells(Boucl, 1)

'*** ------------------------------------------------------------------------------
        For i = LBound(Tabqts) To UBound(Tabqts)
        ' instanciation
        Set reg = New VBScript_RegExp_55.RegExp
            ' A-1. Les propriétés.
            ' -------------------
                reg.Pattern = Tabqts(i)
                ' Active ou non la recherche sur plusieurs lignes à la fois / La propriété est mise sur False par défaut / Multiline (booléen).
                    reg.MultiLine = False
                ' Précise si la recherche est sensible ou non à la casse (majuscules/minuscules) / La propriété est mise sur False par défaut / IgnoreCase (booléen).
                    reg.IgnoreCase = False
                ' Précise si la recherche porte sur la première occurence ou sur toutes / La propriété est mise sur False par défaut.
                    reg.Global = True
            ' A-2. Les méthodes.
            ' -----------------
                'le .Test renvoie True si le motif défini en Pattern est trouvé dans la chaîne / Test (validation).
                    'MsgBox reg.Test(Phrase)
        '*** ------------------------------------------------------------------------------
            ' Cette méthode permet d'explorer les occurences qui vérifient le Pattern / Execute (exploration).
            ' Resultat
            If reg.Test(Phrase) = True Then
                Set Matches = reg.Execute(Phrase)
                    For Each Match In Matches
                        Debug.Print "source >>", Match.Value
        '                For j = 0 To Match.SubMatches.Count - 1
        '                    Debug.Print "[$" & j + 1 & "]", Match.SubMatches(j)
        '                Next j
        '           cellule c1 = Cells(1, 3)
                    ' couleur du texte
                    mFactiv.Cells(Boucl, 1).Characters(Start:=Match.FirstIndex, Length:=Match.Length + 1).Font.FontStyle = "Gras"
                    mFactiv.Cells(Boucl, 1).Characters(Start:=Match.FirstIndex, Length:=Match.Length + 1).Font.Color = -16776961
                    'Cells(1, 3) = Cells(1, 3) & (Match.Value) & vbCrLf
                    Next Match
            ' si trouvé sort de la boucle
            Exit For
        End If
        Next i
Next Boucl
End Sub

Le fichier excel = TrouveDoublonColoreModuleClasse.xlsm

Laurent
 

Pièces jointes

  • TrouveDoublonColoreModuleClasse.xlsm
    38.8 KB · Affichages: 50
  • ExpressionReguliereRegex.JPG
    ExpressionReguliereRegex.JPG
    56.2 KB · Affichages: 30

Jacques25

XLDnaute Occasionnel
Re bonjour,

Le programme de Laurent marche très bien j'ai réussi à faire ce que je voulais. Ca marche aussi très bien avec les formules ;-) Merci à tous les 2.
J'aurai juste quelques questions pour la compréhension :
Laurent, quelle différence entre module et un module de classe?
ODVJ, j'ai pas trop compris le *1000 et le -1 dans ta formule, comme ce sont des formules matricielles peut être ceci explique cela...

Encore merci

@ plus
Jaxk
 

Discussions similaires

Statistiques des forums

Discussions
311 725
Messages
2 081 943
Membres
101 849
dernier inscrit
florentMIG