Navigation

Inscrivez-vous gratuitement
pour pouvoir participer, suivre les réponses en temps réel, voter pour les messages, poser vos propres questions et recevoir la newsletter

Macros et VBA Excel Discussion :

Recherche similitudes mais pas exactement entre deux colonnes


Sujet :

Macros et VBA Excel

  1. #1
    Membre habitué
    Recherche similitudes mais pas exactement entre deux colonnes
    Bonjour à tous,

    Je viens vers vous pour un problème de gestion de données sur Excel, je ne sais pas trop si ce dont j'ai besoin est possible, je vous expose le truc. J'ai deux colonnes, contenant chacune une longue liste de noms de fichiers. J'aimerais pouvoir comparer ces deux colonnes pour repérer les fichiers qui s'y trouvent en double. Problème : tous ces noms de fichiers n'ont pas été saisis par la même personne, donc même si un fichier est en doublon dans les deux colonnes, le nom du fichier risque de ne pas être à 100% la même chaîne de caractères, suivant la nomenclature qu'a décidé la personne. Ca risque quand même d'être très approchant vu qu'il s'agirait du même fichier, mais pas exactement la même chose.

    Y a t il donc possibilité de comparer les données des deux colonnes et de relever les similitudes en fonction d'un pourcentage ? Par exemple copier dans une troisième colonne tous les noms de fichiers avec une ressemblance de 80% ?

    Comme dis, je n'ai aucune idée de si c'est faisable (j'ai déjà regardé sur Internet, mais rien en dehors de la façon de comparer en cherchant exactement la même chaîne de caractères), et si ça l'est, ça doit être assez technique donc je n'ai aucune idée de comment mettre ça en place.

    Merci beaucoup d'avance à ceux qui se pencheront sur mon problème !

  2. #2
    Inactif  
    Bonjour
    exemple
    Code :Sélectionner tout -Visualiser dans une fenêtre à part
    1
    2
    3
    Sub test()
    MsgBox ressemblance("comparer deux chaines", "camparér deus chaines") & "% de ressemblance"
    End Sub

    Code :Sélectionner tout -Visualiser dans une fenêtre à part
    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    14
    15
    16
    17
    18
    19
    20
    21
    22
    23
    24
    25
    26
    27
    28
    29
    30
    31
    32
    33
    34
    35
    36
    37
    38
    39
    40
    41
    42
    43
    44
    45
    46
    47
    48
    49
    50
    51
    52
    Public Function ressemblance(ByVal s1 As String, ByVal s2 As String) As Single
    'Calcul la similarité (de [0 à 1]) entre deux chaines d'après l'algorithme de Damerau-Levenshtein
    'références : http://en.wikipedia.org/wiki/Damerau%E2%80%93Levenshtein_distance
    '             http://mwh.geek.nz/2009/04/26/python-damerau-levenshtein-distance/
    '             http://www-igm.univ-mlv.fr/~lecroq/seqcomp/node2.html
    'Remarques  : Préparer les chaines car les comparaisons sont binaires : UCase(), Trim(),...
    'Philben v1.0 - Free to Use
       Const cFacteur As Long = &H100&, cMaxLen As Long = 256&   'Longueur maxi autorisée des chaines analysées
       Dim l1 As Long, l2 As Long, c1 As Long, c2 As Long
        Dim r() As Integer, rp() As Integer, rpp() As Integer, i As Integer, j As Integer
        Dim c As Integer, x As Integer, y As Integer, z As Integer, f1 As Integer, f2 As Integer
        Dim dls As Single, ac1() As Byte, ac2() As Byte
        l1 = Len(s1): l2 = Len(s2)
        If l1 > 0 And l1 <= cMaxLen And l2 > 0 And l2 <= cMaxLen Then
           ac1 = s1: ac2 = s2   'conversion des chaines en tableaux de bytes
           'Initialise la ligne précédente (rp) de la matrice
          ReDim rp(0 To l2)
           For i = 0 To l2: rp(i) = i: Next i
           For i = 1 To l1
              'Initialise la ligne courante de la matrice
             ReDim r(0 To l2): r(0) = i
              'Calcul le CharCode du caractère courant de la chaine
             f1 = (i - 1) * 2: c1 = ac1(f1 + 1) * cFacteur + ac1(f1)
              For j = 1 To l2
                 f2 = (j - 1) * 2: c2 = ac2(f2 + 1) * cFacteur + ac2(f2)
                 c = -(c1 <> c2)   'Cout : True = -1 => c = 1
                 'suppression, insertion, substitution
                x = rp(j) + 1: y = r(j - 1) + 1: z = rp(j - 1) + c
                 If x < y Then
                    If x < z Then r(j) = x Else r(j) = z
                 Else
                    If y < z Then r(j) = y Else r(j) = z
                 End If
                 'transposition
                If i > 1 And j > 1 And c = 1 Then
                    If c1 = ac2(f2 - 1) * cFacteur + ac2(f2 - 2) And c2 = ac1(f1 - 1) * cFacteur + ac1(f1 - 2) Then
                       If r(j) > rpp(j - 2) + c Then r(j) = rpp(j - 2) + c
                    End If
                 End If
              Next j
              'Reculer d'un niveau la ligne précédente (rp) et courante (r)
             rpp = rp: rp = r
           Next i
           'Calcul la similarité via la distance entre les chaines r(l2)
          If l1 >= l2 Then dls = 1 - r(l2) / l1 Else dls = 1 - r(l2) / l2
        ElseIf l1 > cMaxLen Or l2 > cMaxLen Then
           dls = -1   'indique un dépassement de longueur de chaine
       ElseIf l1 = 0 And l2 = 0 Then
           dls = 1   'cas particulier
       End If
        ressemblance = dls
    End Function

    a toi de décider après quel est le niveau de ressemblance acceptable pour accepter la chaine comme doublon

    ajustement
    pour une veracité plus importante un prétraitement était requis
    Code :Sélectionner tout -Visualiser dans une fenêtre à part
    1
    2
    3
    Sub test()
        MsgBox ressemblance("comparer deux chaine", "camparér deus chaine") & "% de ressemblance"
    End Sub
    Code :Sélectionner tout -Visualiser dans une fenêtre à part
    1
    2
    3
    4
    5
    6
    7
    8
    9
    Function pré_traitement(chaine As String)
        acc = Array("é", "è", "ê", "à", "ï")
        repl = Array("e", "e", "e", "a", "e", "i")
        For i = 0 To UBound(acc)
            chaine = Replace(chaine, acc(i), repl(i))
        Next
        chaine = UCase(chaine)
        pré_traitement = chaine
    End Function
    Code :Sélectionner tout -Visualiser dans une fenêtre à part
    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    14
    15
    16
    17
    18
    19
    20
    21
    22
    23
    24
    25
    26
    27
    28
    29
    30
    31
    32
    33
    34
    35
    36
    37
    38
    39
    40
    41
    42
    43
    44
    45
    46
    47
    48
    49
    50
    51
    52
    53
    54
    55
     
    Public Function ressemblance(ByVal s1 As String, ByVal s2 As String) As Single
    'Calcul la similarité (de [0 à 1]) entre deux chaines d'après l'algorithme de Damerau-Levenshtein
    'références : http://en.wikipedia.org/wiki/Damerau%E2%80%93Levenshtein_distance
    '             http://mwh.geek.nz/2009/04/26/python-damerau-levenshtein-distance/
    '             http://www-igm.univ-mlv.fr/~lecroq/seqcomp/node2.html
    'Remarques  : Préparer les chaines car les comparaisons sont binaires : UCase(), Trim(),...
    'Philben v1.0 - Free to Use
        Const cFacteur As Long = &H100&, cMaxLen As Long = 256&   'Longueur maxi autorisée des chaines analysées
        Dim l1 As Long, l2 As Long, c1 As Long, c2 As Long
        Dim r() As Integer, rp() As Integer, rpp() As Integer, i As Integer, j As Integer
        Dim c As Integer, x As Integer, y As Integer, z As Integer, f1 As Integer, f2 As Integer
        Dim dls As Single, ac1() As Byte, ac2() As Byte
        s1 = pré_traitement(s1)
        s2 = pré_traitement(s2)
        l1 = Len(s1): l2 = Len(s2)
        If l1 > 0 And l1 <= cMaxLen And l2 > 0 And l2 <= cMaxLen Then
            ac1 = s1: ac2 = s2   'conversion des chaines en tableaux de bytes
            'Initialise la ligne précédente (rp) de la matrice
            ReDim rp(0 To l2)
            For i = 0 To l2: rp(i) = i: Next i
            For i = 1 To l1
                'Initialise la ligne courante de la matrice
                ReDim r(0 To l2): r(0) = i
                'Calcul le CharCode du caractère courant de la chaine
                f1 = (i - 1) * 2: c1 = ac1(f1 + 1) * cFacteur + ac1(f1)
                For j = 1 To l2
                    f2 = (j - 1) * 2: c2 = ac2(f2 + 1) * cFacteur + ac2(f2)
                    c = -(c1 <> c2)   'Cout : True = -1 => c = 1
                    'suppression, insertion, substitution
                    x = rp(j) + 1: y = r(j - 1) + 1: z = rp(j - 1) + c
                    If x < y Then
                        If x < z Then r(j) = x Else r(j) = z
                    Else
                        If y < z Then r(j) = y Else r(j) = z
                    End If
                    'transposition
                    If i > 1 And j > 1 And c = 1 Then
                        If c1 = ac2(f2 - 1) * cFacteur + ac2(f2 - 2) And c2 = ac1(f1 - 1) * cFacteur + ac1(f1 - 2) Then
                            If r(j) > rpp(j - 2) + c Then r(j) = rpp(j - 2) + c
                        End If
                    End If
                Next j
                'Reculer d'un niveau la ligne précédente (rp) et courante (r)
                rpp = rp: rp = r
            Next i
            'Calcul la similarité via la distance entre les chaines r(l2)
            If l1 >= l2 Then dls = 1 - r(l2) / l1 Else dls = 1 - r(l2) / l2
        ElseIf l1 > cMaxLen Or l2 > cMaxLen Then
            dls = -1   'indique un dépassement de longueur de chaine
        ElseIf l1 = 0 And l2 = 0 Then
            dls = 1   'cas particulier
        End If
        ressemblance = dls * 100
    End Function
    mes fichiers dans les contributions:
    mail avec CDO en vba et mail avec CDO en vbs dans un HTA
    survol des bouton dans userform
    prendre un cliché d'un range

    si ton problème est résolu n'oublie pas de pointer : : ça peut servir aux autres
    et n'oublie pas de voter

  3. #3
    Membre habitué
    Bonjour patricktoulon, et merci beaucoup pour tes réponses ! Le problème maintenant, c'est que ce code est vraiment très complexe... Du coup je ne vois pas du tout comment l'adapter à mon simple fichier Excel, vu que je n'ai pas repéré de ligne pour définir les plages de cellules à traiter, et je ne me sens pas du tout capable de tripatouiller là dedans

  4. #4
    Membre expert
    Bonjour à tous,

    Tu as l'addin de MS Fuzzy Lookup (recherche floue) qui pourrait t'intéresser : https://www.microsoft.com/en-us/down....aspx?id=15011
    Puissant et beaucoup plus rapide qu'un code en vba (selon ton volume de comparaisons à faire).
    Une présentation ici : http://www.emarketeur.fr/ressources/...-vieux-vlookup

    Et si tu as besoin de faire une fonction plus personnalisée il faut utiliser l'algorithme sur la distance de Levenshtein donné par patrick.
    eric

  5. #5
    Membre extrêmement actif
    Bonjour
    Rien n'est à mon sens plus complexe à définir que la "ressemblance", en matière de textes.
    Pour les uns, elle passe surtout par l'étude des caractères successifs
    Pour d'autres, dont moi-même, par l'étude des phonèmes présents (et ce n'est pas simple). C'EST CE MECANISME, QUI EST A PRIVILEGIER, EN MATIERE DE COMPARAISON DE NOMS (le cas présent).
    Pour d'autres, enfin, elle passe par l'étude de la "moelle" des principales propositions des textes (et c'est encore plus complexe, mais cela ne concerne pas le cas présent).
    Je n'accepte pas de demande d' "amitié" individuelle. Tout développeur est pour moi un ami.
    Je n'ouvre AUCUN classeur tiers (avec ou sans macro ******). Ne m'en proposez donc pas .

    ****** : Non, non ... un classeur .xlsx ne "peut" par exemple et entre autres pas contenir un activex (de surcroît invisible) , "bien sûr" ...

    Il est illusoire de penser que l'on saurait exprimer valablement et précisément en un langage (rigide) de développement ce que l'on peine à exprimer dans le langage naturel, bien plus souple.

  6. #6
    Membre habitué
    Merci pour vos réponse à tous les deux. J'ai téléchargé Fuzzy Lookup, ça a l'air plutôt intéressant, je vais voir ce que ça donne

###raw>template_hook.ano_emploi###