Bonjour à vous,

Je sollicite votre aide aujourd'hui. J'ai présentement du code permettant de faire une recherche de valeur dans un autre onglet et de retourner toute les occurrences selon le pourcentage de similarité et ce en ordre décroissant. J'ai plusieurs informations que j'ai besoin et présentement, je dois refaire cette recherche à chaque fois afin d'avoir l'information, ce qui est très long.

Je voudrais alors modifier mes codes actuels afin d'exécuter une seul fois la recherche afin de gagner du temps d'exécution.


Voici mes codes :

Celui de la similarité

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
   Function SimilaritePourcent(chaine1 As String, chaine2 As String) As Double
    Dim i As Long, matchCount As Long
    Dim len1 As Long, len2 As Long, minLen As Long, maxLen As Long
 
    ' Convertir en minuscules pour comparaison insensible à la casse
    chaine1 = LCase$(chaine1)
    chaine2 = LCase$(chaine2)
 
    ' Calculer les longueurs
    len1 = Len(chaine1)
    len2 = Len(chaine2)
    minLen = IIf(len1 < len2, len1, len2)
    maxLen = IIf(len1 > len2, len1, len2)
 
    ' Comparer les caractères un à un
    For i = 1 To minLen
        If Mid$(chaine1, i, 1) = Mid$(chaine2, i, 1) Then
            matchCount = matchCount + 1
        End If
    Next i
 
    ' Calcul du pourcentage
    If maxLen > 0 Then
        SimilaritePourcent = (matchCount / maxLen) * 100
    Else
        SimilaritePourcent = 0
    End If
End Function
Celui permettant de faire la recherche

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
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
Sub similarite_rmult_multiple(plListe As Range, plageRech As Range, plagesRecup() As Variant, plsDest() As Variant)
    Dim rech As Variant, recups() As Variant, liste As Variant
    Dim dicts() As Object
    Dim i As Long, j As Long
    Dim seuil As Double
    Dim valListe As String, matches As String
    Dim sim As Double
    Dim cle As Variant
 
    Dim tmpResult() As String
    Dim results() As Variant
 
    ' Vérification des limites des tableaux
    If Not IsArray(plagesRecup) Or Not IsArray(plsDest) Then
        MsgBox "Les plages de récupération ou de destination ne sont pas valides.", vbCritical
        Exit Sub
    End If
 
    If UBound(plagesRecup) <> UBound(plsDest) Then
        MsgBox "Les dimensions des tableaux plagesRecup et plsDest doivent être identiques.", vbCritical
        Exit Sub
    End If
 
    ' Entrée et validation du seuil
    seuil = val(InputBox("Entrez le pourcentage minimal de similarité (0-100)", "Seuil de similarité"))
    If seuil <= 0 Or seuil > 100 Then
        MsgBox "Seuil invalide. Opération annulée.", vbExclamation
        Exit Sub
    End If
 
    ' Chargement des tableaux
    rech = plageRech.Value2
    liste = plListe.Value2
 
    ReDim recups(LBound(plagesRecup) To UBound(plagesRecup))
    ReDim dicts(LBound(plagesRecup) To UBound(plagesRecup))
    ReDim results(LBound(plagesRecup) To UBound(plagesRecup))
 
    For j = LBound(plagesRecup) To UBound(plagesRecup)
        recups(j) = plagesRecup(j).Value2
        Set dicts(j) = CreateObject("Scripting.Dictionary")
 
        ' Construire les dictionnaires par colonne
        For i = 1 To UBound(rech, 1)
            Dim cleTemp As String
            cleTemp = CStr(rech(i, 1))
            If dicts(j).Exists(cleTemp) Then
                dicts(j)(cleTemp) = dicts(j)(cleTemp) & vbLf & recups(j)(i, 1)
            Else
                dicts(j).Add cleTemp, recups(j)(i, 1)
            End If
        Next i
 
        ' Initialiser le tableau de résultats pour cette colonne
        ReDim tmpResult(1 To UBound(liste, 1), 1 To 1)
        results(j) = tmpResult
    Next j
 
    ' Traitement de similarité
    For i = 1 To UBound(liste, 1)
        valListe = CStr(liste(i, 1))
 
        For j = LBound(dicts) To UBound(dicts)
            Dim tempMatches() As Variant
            Dim tempIndex As Long: tempIndex = -1
            matches = ""
 
            ' Comparaison avec chaque clé du dictionnaire pour la colonne j
            For Each cle In dicts(j).keys
                sim = SimilaritePourcent(valListe, CStr(cle))
                If sim >= seuil Then
                    Dim lignes() As String
                    lignes = Split(dicts(j)(cle), vbLf)
                    Dim l As Variant
                    For Each l In lignes
                        tempIndex = tempIndex + 1
                        If tempIndex = 0 Then
                            ReDim tempMatches(0)
                        Else
                            ReDim Preserve tempMatches(0 To tempIndex)
                        End If
                        tempMatches(tempIndex) = Array(l, sim)
                    Next l
                End If
            Next cle
 
            ' Tri par similarité décroissante
            If tempIndex >= 0 Then
                Dim a As Long, b As Long, temp As Variant
                For a = 0 To tempIndex - 1
                    For b = a + 1 To tempIndex
                        If tempMatches(a)(1) < tempMatches(b)(1) Then
                            temp = tempMatches(a)
                            tempMatches(a) = tempMatches(b)
                            tempMatches(b) = temp
                        End If
                    Next b
                Next a
 
                ' Concaténer les résultats triés dans la variable matches
                For a = 0 To tempIndex
                    matches = matches & tempMatches(a)(0) & " - " & Format(tempMatches(a)(1), "0") & "%" & vbLf
                Next a
 
                ' Retirer le dernier retour à la ligne
                If Right(matches, 1) = vbLf Then matches = Left(matches, Len(matches) - 1)
                results(j)(i, 1) = matches
            Else
                results(j)(i, 1) = "Aucune correspondance"
            End If
        Next j
    Next i
 
    ' Écriture des résultats dans chaque plage
    For j = LBound(plsDest) To UBound(plsDest)
        plsDest(j).Resize(UBound(liste, 1), 1).Value = results(j)
    Next j
End Sub
Celui permettant de définir les plages à chercher /retourner comme résultats

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
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
Sub soumission_comparaison_similarite()
 
    Dim i As Long
 
    Dim Dico As Object
 
    Dim clé As String
 
    Dim TblBD1 As Variant
 
    Dim LettreCode As String
    Dim LettreP_trouve As String
    Dim LettreDescr_trouve As String
    Dim LettreF_trouve As String
    Dim LettreC_trouve As String
    Dim LettreG_trouve As String
    Dim LettreSG_trouve As String
    Dim LettreStatut_trouve As String
 
    LettreCode = TrouveLettreColonne([code_distr])
    LettreP_trouve = TrouveLettreColonne([p_trouve])
    LettreDescr_trouve = TrouveLettreColonne([descr_trouve])
    LettreF_trouve = TrouveLettreColonne([f_trouve])
    LettreC_trouve = TrouveLettreColonne([c_trouve])
    LettreG_trouve = TrouveLettreColonne([g_trouve])
    LettreSG_trouve = TrouveLettreColonne([sg_trouve])
    LettreStatut_trouve = TrouveLettreColonne([statut])
 
    Dim PlageTravail_Code As Range
    Dim PlageTravail_LettreP_trouve As Range
    Dim PlageTravail_LettreDescr_trouve As Range
    Dim PlageTravail_LettreF_trouve As Range
    Dim PlageTravail_LettreC_trouve As Range
    Dim PlageTravail_LettreG_trouve As Range
    Dim PlageTravail_LettreSG_trouve As Range
    Dim PlageTravail_LettreStatut_trouve As Range
 
    Dim PlageSoumission_No_manuf As Range
    Dim PlageSoumission_No_item As Range
    Dim PlageSoumission_Desc_prov As Range
    Dim PlageSoumission_No_famille As Range
    Dim PlageSoumission_No_classe As Range
    Dim PlageSoumission_No_groupe As Range
    Dim PlageSoumission_No_ss_groupe As Range
    Dim PlageSoumission_Statut As Range
 
    Dim start As Single
    Dim finish As Single
 
    start = Timer
 
    Application.ScreenUpdating = False
 
 
'On Error GoTo errorhandler:
 
 
'on set les range afin de faciliter la rmult_dico_unique
 
    With Worksheets("Travail")
 
 
    Set PlageTravail_Code = .Range(LettreCode & 2, LettreCode & LastLignUsedInSheet_Column("Travail", LettreCode))
    Set PlageTravail_LettreP_trouve = .Range(LettreP_trouve & 2, LettreP_trouve & LastLignUsedInSheet_Column("Travail", LettreCode))
    Set PlageTravail_LettreDescr_trouve = .Range(LettreDescr_trouve & 2, LettreDescr_trouve & LastLignUsedInSheet_Column("Travail", LettreCode))
    Set PlageTravail_LettreF_trouve = .Range(LettreF_trouve & 2, LettreF_trouve & LastLignUsedInSheet_Column("Travail", LettreCode))
    Set PlageTravail_LettreC_trouve = .Range(LettreC_trouve & 2, LettreC_trouve & LastLignUsedInSheet_Column("Travail", LettreCode))
    Set PlageTravail_LettreG_trouve = .Range(LettreG_trouve & 2, LettreG_trouve & LastLignUsedInSheet_Column("Travail", LettreCode))
    Set PlageTravail_LettreSG_trouve = .Range(LettreSG_trouve & 2, LettreSG_trouve & LastLignUsedInSheet_Column("Travail", LettreCode))
    Set PlageTravail_LettreStatut_trouve = .Range(LettreStatut_trouve & 2, LettreStatut_trouve & LastLignUsedInSheet_Column("Travail", LettreCode))
 
 
    Set Dico = CreateObject("Scripting.Dictionary")
    TblBD1 = .Range(LettreCode & 2, LettreCode & LastLignUsedInSheet_Column("Travail", LettreCode))
 
 
    End With
 
 
    With Worksheets("soumission")
 
 
    Set PlageSoumission_No_manuf = .Range("A2:a" & LastLignUsedInSheet_Column("soumission", "A"))
    Set PlageSoumission_No_item = .Range("B2:B" & LastLignUsedInSheet_Column("soumission", "A"))
    Set PlageSoumission_Desc_prov = .Range("C2:C" & LastLignUsedInSheet_Column("soumission", "A"))
    Set PlageSoumission_No_famille = .Range("D2:D" & LastLignUsedInSheet_Column("soumission", "A"))
    Set PlageSoumission_No_classe = .Range("E2:E" & LastLignUsedInSheet_Column("soumission", "A"))
    Set PlageSoumission_No_groupe = .Range("F2:F" & LastLignUsedInSheet_Column("soumission", "A"))
    Set PlageSoumission_No_ss_groupe = .Range("G2:G" & LastLignUsedInSheet_Column("soumission", "A"))
    Set PlageSoumission_Statut = .Range("H2:H" & LastLignUsedInSheet_Column("soumission", "A"))
 
 
    End With
 
 
 
'On valide si il y a un numéro d'item sinon on avise et quit
 
    If LastLignUsedInSheet_Column("Travail", LettreCode) = 1 Then
 
        MsgBox "Il n'y a pas de code distributeur/manufacturier !!!", vbInformation
 
        Exit Sub
 
    End If
 
 
'on détruit les cellules ayant les formules si jamais on refais la macro
 
    Union(PlageTravail_LettreP_trouve, PlageTravail_LettreDescr_trouve, PlageTravail_LettreF_trouve, _
          PlageTravail_LettreC_trouve, PlageTravail_LettreG_trouve, PlageTravail_LettreSG_trouve, PlageTravail_LettreStatut_trouve).ClearContents
 
'on transpose le dictionnaire des code distributeur / manufacturier tout en le nettoyant
 
If LastLignUsedInSheet_Column("Travail", LettreCode) > 2 Then
 
    For i = 1 To UBound(TblBD1)
 
 
                clé = CleanAcc(TblBD1(i, 1))
                Dico(clé) = TblBD1(i, 1)
 
    Next i
 
Sheets("Travail").Range(LettreCode & 2).Resize(Dico.Count) = Application.Transpose(Dico.keys)
 
Else
 
    Cells(2, LettreCode) = CleanAcc(Cells(2, LettreCode))
 
End If
 
 
'on détruit les doublons afin d'éviter un bug si il y a plus d'un code
 
    If LastLignUsedInSheet_Column("Travail", LettreCode) > 2 Then
 
        PlageTravail_Code.RemoveDuplicates Columns:=1, Header:=xlNo
 
    End If
 
'on re-set la plage PlageTravail aux cas où il y avait des doublons et que celle-ci à changer
 
 With Worksheets("Travail")
 
 
    Set PlageTravail_Code = .Range(LettreCode & 2, LettreCode & LastLignUsedInSheet_Column("Travail", LettreCode))
    Set PlageTravail_LettreP_trouve = .Range(LettreP_trouve & 2, LettreP_trouve & LastLignUsedInSheet_Column("Travail", LettreCode))
    Set PlageTravail_LettreDescr_trouve = .Range(LettreDescr_trouve & 2, LettreDescr_trouve & LastLignUsedInSheet_Column("Travail", LettreCode))
    Set PlageTravail_LettreF_trouve = .Range(LettreF_trouve & 2, LettreF_trouve & LastLignUsedInSheet_Column("Travail", LettreCode))
    Set PlageTravail_LettreC_trouve = .Range(LettreC_trouve & 2, LettreC_trouve & LastLignUsedInSheet_Column("Travail", LettreCode))
    Set PlageTravail_LettreG_trouve = .Range(LettreG_trouve & 2, LettreG_trouve & LastLignUsedInSheet_Column("Travail", LettreCode))
    Set PlageTravail_LettreSG_trouve = .Range(LettreSG_trouve & 2, LettreSG_trouve & LastLignUsedInSheet_Column("Travail", LettreCode))
    Set PlageTravail_LettreStatut_trouve = .Range(LettreStatut_trouve & 2, LettreStatut_trouve & LastLignUsedInSheet_Column("Travail", LettreCode))
 
End With
 
 
'faire rmult_dico afin d'avoir les P_trouvés
 
    similarite_rmult PlageTravail_Code, PlageSoumission_No_manuf, PlageSoumission_No_item, PlageTravail_LettreP_trouve
 
 
Application.ScreenUpdating = True
 
 
finish = Timer
MsgBox "durée du traitement: " & finish - start & " secondes"
 
Exit Sub
 
errorhandler: MsgBox "cliquer sur le bouton update !!!"
 
End Sub
POur résumé, dans la partie

Code : Sélectionner tout - Visualiser dans une fenêtre à part
1
2
3
'faire rmult_dico afin d'avoir les P_trouvés
 
    similarite_rmult PlageTravail_Code, PlageSoumission_No_manuf, PlageSoumission_No_item, PlageTravail_LettreP_trouve
Je voudrais avoir comme résultat au lieu de
PlageSoumission_No_item
un array et comme retour un array de même grandeur dans
PlageTravail_LettreP_trouve
. Ça serais comme si on ferais une rechercheV et au lieu de spécifié la colonne auquel ont veux un retour d'information, on en spécifie plusieurs ainsi que l'endroit de destinations.

AVec l'utilisation de union, cela me retourne la première information (possiblemnt dû à la redimension de tableau, et en utilisant, array, cela cause des erreurs.

J'ai également essayé les IA mais disons que c'est perdre sont temps ... on corrige en créant un autre problème ou tout en gardant les mêmes erreurs.

merci beaucoup pour votre aide / pistes de solutions