Discussion :

[jpenja]

Bonjour à tous.
Pour commencer je précise que je ne connais pas grand chose en VBA mais il me semble compliquer de faire ce que je souhaite sans passer par de la programmation. Je m'explique :
je dispose pour plusieurs années de séries de chiffres dans un ordre précis (environ une centaine de code à 14 chiffres par année et sur 10 années).
Je voudrais parmi toutes ces données retrouver les doublons ou presque doublons à 1 ou 2 chiffres prêts.
Ci joint un exemple de mes données :

Année1	Annee2	Année3
32311232331211	11231123112323	11212232311232
11223323211231	22312231211113	22331331122132
22312233112231	22312232111132	32311232331211
12231223311212	11223323211231	32312231123231
22311231123231	32112322123123	22312132111132
32312231123231	32311232331211	33322112132122

Et ainsi de suite.Je précise que les codes de 14 chiffres ne contiennent que des 1, 2 ou 3. on voit que le code 32311232331211 se retrouve à plusieurs endroits et que par exemple les codes 22312232111132 et 22312132111132 son identiques à 1 chiffre prêt.

Merci à tous ceux qui se pencheront sur mon problème et m'apporteront une solution éventuelle si celà est possible.

[Invité]

Bonjour,

A tester :

Pièce jointe 364064

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
 
Option Explicit
 
Function ChaineTronquee(ByVal ChaineDeReference As String, ByVal Position As Integer) As String
 
    Application.Volatile
    If Position <= Len(ChaineDeReference) Then
        Select Case Position
                Case 1
                     ChaineTronquee = Mid(ChaineDeReference, 2)
                Case 2 To Len(ChaineDeReference) - 1
                     ChaineTronquee = Mid(ChaineDeReference, 1, Position - 1) & Mid(ChaineDeReference, Position + 1)
                Case Len(ChaineDeReference)
                     ChaineTronquee = Mid(ChaineDeReference, 1, Position - 1)
        End Select
    End If
 
End Function
 
 
Sub TrouverLesChaines()
 
Dim AireRecherche As Range, CelluleRecherche As Range
Dim ValeurCherchee As String
Dim I As Integer
Dim Lignetitre As Long, DerniereLigne As Long, DerniereColonne As Long
 
 
    With Sheets("Nombres par années")
 
         Lignetitre = 10
         DerniereColonne = .Cells(Lignetitre, .Columns.Count).End(xlToLeft).Column
         DerniereLigne = .UsedRange.SpecialCells(xlCellTypeLastCell).Row
         ValeurCherchee = .Range("ValeurAChercher")
 
         Set AireRecherche = .Range(.Cells(Lignetitre + 1, 1), .Cells(DerniereLigne, DerniereColonne))
 
         AireRecherche.Interior.ColorIndex = xlNone
 
         For I = 1 To Len(ValeurCherchee)
            For Each CelluleRecherche In AireRecherche
                If ChaineTronquee(ValeurCherchee, I) = ChaineTronquee(CelluleRecherche, I) Then
                   CelluleRecherche.Interior.Color = RGB(255, 255, 0)
                End If
            Next CelluleRecherche
         Next I
 
         Set AireRecherche = Nothing
 
    End With
 
End Sub

[hyperion13]

Salut,
Pour compléter la réponse d'Éric, sans vba et sur une MFC

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

=SI(A11=$B$5;SI(STXT(A11;1;NBCAR(A11)-1)=STXT($B$5;1;NBCAR($B$5)-1);VRAI;SI(STXT(A11;1;NBCAR(A11)-2)=STXT($B$5;1;NBCAR($B$5)-2);VRAI;FAUX)))

[Pierre Fauconnier]

Salut.

Pour repérer tous les vrais doublons par MFC, il me semble qu'un NB.SI.ENS peut suffire



Par contre, pour les faux doublons, à part en VBA, je ne vois pas de solution, surtout si le chiffre de différence peut se trouver n'importe où dans la suite.

[unparia]

Bonjour Pierre
Une solution existerait, mais :
1) sur la base d'une usine à gaz épouvantable
2) la durée de traitement serait aussi épouvantable que l'usine

Elle consisterait en :
1) modifier tour à tour toutes les données en supprimant à chaque fois l'un de ses caractères à la même position (que l'on fait varier du premier au dernier caractère)
2) rechercher les doublons réels sur ces données "tronquées" à chaque fois

il y en a peut-être (je n'en suis pas certains) une autre, non moins lente et scabreuse :
mettre dans une feuille tremplin les checksums des données et essayer de travailler sur la base des écarts entre ces checksums.

Je ne vois personnellement rien d'autre à ce stade de mes réflexions personnellement.
En précisant que j'ai du écarter de mes réflexions l'utilisation d'autres procédés que j'envisageais, du seul fait que la transposition en valeurs numériques de chaines si longues n'est pas envisageable.

[unparia]

J'ai beau y penser et y repenser, la seule petite possibilité de réduire (très peu) l'usine à gaz de ma première idée, consisterait en ceci :
1) mettre sur deux colonnes (les données de chaque colonne à la suite de l'autre) :
- en colonne 1 les données
- en colonne 2 leur n° de ligne
2) insérer 14 colonnes entre les deux premières colonnes
3) éclater sur les 14 colonnes insérer les 14 caractères de chacune des données
4) puis : successivement :
- masquer la colonne 2 et -->> détermination des doublons
- réafficher la colonne 2 et( masquer la colonne 3 ) -->> détermination des doublons
etc ... jusqu'à la colonne 15
Ce serait quand même une usine à gaz également, mais peut-être un peu moins lente que la première. (Je n'ai pas essayé).

[hyperion13]

Salut.
Pour repérer tous les vrais doublons par MFC, il me semble qu'un NB.SI.ENS peut suffire

Bonjour Pierre, je l'oublie toujours cette fonction NB.Si.ENS() sur Xl2013.

Par contre, pour les faux doublons, à part en VBA, je ne vois pas de solution, surtout si le chiffre de différence peut se trouver n'importe où dans la suite.

Par valeur proche il faut, mathématiquement comprendre terminaison de chacune des valeurs à contrôler.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

32311232331211 > 3231123233121 > 323112323312

D'ailleurs pour la MFC

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

=SI(OU(A11=$B$5;A11=CNUM(STXT($B$5;1;NBCAR($B$5)-1));A11=CNUM(STXT($B$5;1;NBCAR($B$5)-2));A11=CNUM(STXT($B$5;1;NBCAR($B$5)-3)));VRAI;FAUX)

[Pierre Fauconnier]

Salut Hypérion,

Vu l'exemple de valeurs proches exposé par jpenja

[...]par exemple les codes 22312232111132 et 22312132111132 son identiques à 1 chiffre prêt.

[...]

Je ne suis pas certain que ta définition de valeur proche convienne

[...]
Par valeur proche il faut, mathématiquement comprendre terminaison de chacune des valeurs à contrôler.[...]

Pour ma part, je conclus des explications et exemples donnés que les deux suites peuvent varier à un chiffre près, où qu'il se trouve dans la suite, et sauf éventuelle usine à gaz que je préfère ne pas imaginer, je ne vois pas de solution sans VBA. C'est pourquoi je pense qu'il faut scinder la recherche en deux:

• une première recherche pour les doublons réels, que l'on peut faire en VBA si on le souhaite en utilisant Application.Countifs ou Evaluate en boucle sur les valeurs de la plage à tester;
• une recherche des faux doublons, après avoir bien précisé en quoi consiste un faux doublon, que je testerais par fonction VBA personnalisée en boucle sur les valeurs de la plage à tester.

Et je collationnerais les résultats dans un tableau, par exemple, pour signaler les vrais et faux doublons. Si on réalise le tout en regroupant les tests au sein d'une fonction unique, il serait peut-être possible d'utiliser cette fonction au sein d'une MFC (solution que je préfère à une procédure qui colorerait les données, personnellement).

[patricktoulon]

re
bonjour
il existe des algorytmes en vba pour les similaires je vais essayer de les retrouver dans mes ".rar" sinon une recherche sur le net devrait donner un resultat

en attendant une petite fonction a utiliser avec formule

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
Public Function PresqueIdentique(cel1 As Range, cel2 As Range, pourcentage)
    Dim nbcar, i As Long, res
    nbcar = Application.Max(Len(cel1), Len(cel2))
    For i = 1 To nbcar
        If Mid(CStr(cel1.Text), i, 1) = Mid(CStr(cel2.Text), i, 1) Then x = x + 1
    Next
    Debug.Print nbcar & "  " & x
    res = (x / nbcar) * 100
    If res >= pourcentage Then PresqueIdentique = "retenu  à " & res & "%" Else PresqueIdentique = "non retenu a " & res & "%"
    If Left(cel1.Text, Len(cel1.Text)) = Left(cel2.Text, Len(cel1.Text)) Then PresqueIdentique = "retenu option like": Exit Function
End Function

[hyperion13]

Pierre, désolé je n'avais pas remarqué la subtilité et focalisé sur l'exemple imagé d'Éric
Je vais réfléchir à la problématique malgré tout.

[patricktoulon]

re
Levenshtein vous salut
Merci philben

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
Sub test0()
chaine1 = "22224622"
chaine2 = "222246223"
MsgBox "test numerique " & vbCrLf & "chaine 1=" & chaine1 & vbCrLf & "chaine 2=" & chaine2 & vbCrLf & "resultat = " & similaire(chaine1, chaine2) & "%"
End Sub

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
Sub test1()
chaine1 = "22224622"
chaine2 = "22225622"
MsgBox "test numerique " & vbCrLf & "chaine 1=" & chaine1 & vbCrLf & "chaine 2=" & chaine2 & vbCrLf & "resultat = " & similaire(chaine1, chaine2) & "%"
End Sub

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
Sub test2()
chaine1 = "toto mange des bannanes"
chaine2 = "toto mmange des bannanes"
MsgBox "test non numerique " & vbCrLf & "chaine 1=" & chaine1 & vbCrLf & "chaine 2=" & chaine2 & vbCrLf & "resultat = " & similaire(chaine1, chaine2) & "%"
End Sub

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
Sub test3()
chaine1 = "toto mange des bannanes"
chaine2 = "toto croque des bannanes"
MsgBox "test non numerique " & vbCrLf & "chaine 1=" & chaine1 & vbCrLf & "chaine 2=" & chaine2 & vbCrLf & "resultat = " & similaire(chaine1, chaine2) & "%"
End Sub

arrangé au type de retour de mon besoins
voir le lien tout en bas pour l'original

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
 
Public Function similaire(ByVal s1 As String, ByVal s2 As String) As Double
'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 String, 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
    similaire = dls * 100
End Function

veuillez bien retenir cette ligne pour les chaine non numerique avec accent

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
'Remarques  : Préparer les chaines car les comparaisons sont binaires : UCase(), Trim(),...

POUR L'ORIGINAL C'EST ICI

[unparia]

Voilà à quoi je parviens en utilisant à la louche le mécanisme que j'entrevoyais :

Les données à traiter : sur Feuille "donnees"

1) image de tenants et aboutissants :

2) code d'un bouton à cliquer :

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
Private Sub CommandButton1_Click()
 Application.ScreenUpdating = False
  Dim T As Worksheet, D As Worksheet, ou As Long, c As Range, dja As String, f As Worksheet
  Set D = Worksheets("donnees")
  D.Cells.Interior.ColorIndex = vbnone
  For Each f In ActiveWorkbook.Worksheets
   dja = dja & Chr(1) & f.Name & Chr(1)
  Next
  If InStr(dja, Chr(1) & "tremplin" & Chr(1)) = 0 Then
    ActiveWorkbook.Sheets.Add after:=Worksheets(Worksheets.Count)
    ActiveSheet.Name = "tremplin"
  End If
  Set T = Worksheets("tremplin")
  D.Cells.NumberFormat = "@"
  ou = 1
  For Each c In D.UsedRange.SpecialCells(xlCellTypeConstants)
    T.Range("A" & ou).Value = c.Address
    T.Range("B" & ou & ":O" & ou).Value = Split(StrConv(c.Text, vbUnicode), Chr(0))
    ou = ou + 1
  Next
  tout = T.Range("A1:O" & ou - 1)
 
  With T.Range("A1:O" & ou - 1)
    .RemoveDuplicates Columns:=Array(2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14), Header:=xlNo  'Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14), Header:=xlNo
    .RemoveDuplicates Columns:=Array(3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14), Header:=xlNo
    .RemoveDuplicates Columns:=Array(3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14), Header:=xlNo
    .RemoveDuplicates Columns:=Array(2, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14), Header:=xlNo
    .RemoveDuplicates Columns:=Array(2, 3, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14), Header:=xlNo
    .RemoveDuplicates Columns:=Array(2, 3, 4, 6, 7, 8, 9, 10, 11, 12, 13, 14), Header:=xlNo
    .RemoveDuplicates Columns:=Array(2, 3, 4, 5, 7, 8, 9, 10, 11, 12, 13, 14), Header:=xlNo
    .RemoveDuplicates Columns:=Array(2, 3, 4, 5, 6, 8, 9, 10, 11, 12, 13, 14), Header:=xlNo
    .RemoveDuplicates Columns:=Array(2, 3, 4, 5, 6, 7, 9, 10, 11, 12, 13, 14), Header:=xlNo
    .RemoveDuplicates Columns:=Array(2, 3, 4, 5, 6, 7, 8, 10, 11, 12, 13, 14), Header:=xlNo
    .RemoveDuplicates Columns:=Array(2, 3, 4, 5, 6, 7, 8, 9, 11, 12, 13, 14), Header:=xlNo
    .RemoveDuplicates Columns:=Array(2, 3, 4, 5, 6, 7, 8, 9, 10, 12, 13, 14), Header:=xlNo
    .RemoveDuplicates Columns:=Array(2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 13, 14), Header:=xlNo
    .RemoveDuplicates Columns:=Array(2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 14), Header:=xlNo
    .RemoveDuplicates Columns:=Array(2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13), Header:=xlNo
  End With
  D.UsedRange.Cells.SpecialCells(xlCellTypeConstants).Interior.Color = vbYellow
  For Each c In T.Range("A:A").SpecialCells(xlCellTypeConstants).Cells
    D.Range(c.Text).Interior.ColorIndex = vbnone
  Next
  Application.ScreenUpdating = True
End Sub

Reste à savoir (je n'ai pas essayé) s'il se montre rapide avec un grand nombre de données à traiter.
EDIT : j'ai ici traité, en exemple, les presque-doublons à 1 chiffre près. A extrapoler pour à 2 chiffres près -->> utiliser alors comme arrays successifs toutes les combinaisons de 12 éléments choisis parmi 14

EDIT 2 : J'ai utilisé plus haut l'expression "à la louche", car j'ai laissé en "dur" les différents arrays à appliquer (ce qui permet aux moins avertis de comprendre le mécanisme). Il est bien évidemment très facile de traiter tout cela en boucle.

EDIT 3 : à titre d'information :
Je viens de constituer une plage de 3000 lignes remplies, sur 3 colonnes, de nombres composés de 14 chiffres choisis aléatoirement et composés des chiffres 1,2 et 3
Puis j'ai chronométré la durée de traitement de repérages des doublons et presque-doublons à 1 chiffre près--->> 5,64 secondes sur ma vieille bécane.
J'estime que ce n'est pas mal (je n'en espérais du moins pas tant) . La durée sera sans aucun doute bien plus importante pour une approximation à deux chiffres près (car alors 91 arrays à traiter au lieu de 14)

[jpenja]

Bonjour à vous et merci pour toutes ces solutions proposées même si certaines sont pour moi du presqu'charabia.
En fait pour les vrais doublons j'ai trouvé un solution en passant par les mises en forme conditionnelles et valeur en double puis en sélectionnant toutes mes données.Excel m'a effectivement trouvé des valeurs strictement identiques.
Ce qui me pose maintenant problème c'est les presque doublons et effectivement comme l'a souligné Pierre, la différence peut se trouvée à n'importe quel endroit des 14 positions.
Je vais essayer d'appliquer vos développements et merci encore à tous ceux qui s'y sont penchés.
François.

[Pierre Fauconnier]

Et si tu essayais la fonction de Patrick?

[...]

[eriiic]

Bonjour,

La distance de Levenshtein n'est pas appropriée ici.
Il tient compte du nombre de caractères différents, mais aussi des permutations.
Ainsi 1212;2222 et 1212;2121 auront la même distance de 50, mais le 2nd couple a 4 caractères différents et n'est pas acceptable.
eric

[Igloobel]

Messieurs je pense qu'il y a un oubli

en relisant le POST#1 (ce que je viens de faire) je vois :

Bonjour à tous.
Pour commencer je précise que je ne connais pas grand chose en VBA mais il me semble compliquer de faire ce que je souhaite sans passer par de la programmation. Je m'explique :
je dispose pour plusieurs années de séries de chiffres dans un ordre précis (environ une centaine de code à 14 chiffres par année et sur 10 années)
...

pour moi de ce que je comprend c'est un code composé de chiffres géré comme un string.

qu'en pensez vous ?

[Marc-L]

Aucun oubli via la comparaison par octet …

[Igloobel]

Exact

Mea culpa

[mjpmjp]

bonjour,



@+JP

[patricktoulon]

un regex dans une fonction perso

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
Function coupe_regex2(cel)
    Dim texte As String, chaine As String, matchs
    If TypeName(cel) = "Range" Then texte = cel.Value Else texte = cel
    With CreateObject("VBScript.RegExp"):
        .Global = True: .IgnoreCase = False:
        .Pattern = "([A-Z]{1})([a-z]{1,20})(( [A-Z]{1}\s)|())"
        Set matchs = .Execute(texte)
        'Debug.Print texte & "  occurences = " & matchs.Count
        If matchs.Count > 0 Then
            If matchs.Count > 0 Then r = matchs(0)
            If matchs.Count = 2 Then r = r & " " & matchs(1)
        End If
    End With
    coupe_regex2 = r
End Function
Sub test()
    MsgBox "Capital (SPA) E2" & vbCrLf & coupe_regex2("Capital (SPA) E2")
    MsgBox "Capital SPA E2" & vbCrLf & coupe_regex2("Capital SPA E2")
    MsgBox "Capital SPA" & vbCrLf & coupe_regex2("Capital SPA")
    MsgBox "Capital E1" & vbCrLf & coupe_regex2("Capital E1")
    MsgBox "Capital Capital E1" & vbCrLf & coupe_regex2("Capital Capital E1")
    MsgBox "Capital Capital SPA" & vbCrLf & coupe_regex2("Capital Capital SPA")
    MsgBox "Slick Knight (GB) E1" & vbCrLf & coupe_regex2("Slick Knight (GB) E1")
    MsgBox "Slick Knight GB E1" & vbCrLf & coupe_regex2("Slick Knight GB E1")
    MsgBox "Should I Stay E1" & vbCrLf & coupe_regex2("Should I Stay E1")
    MsgBox "Should I Stay (ADF) E1" & vbCrLf & coupe_regex2("Should I Stay  (ADF) E1")
End Sub

fallait pas tenter le toulonnais