retour de plusieurs informations au lieu de 1

**jpvba** · 12/05/2025, 21h18

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

**Qwazerty** · 12/05/2025, 22h34

Salut

Ça fait beaucoup de code, je ne suis pas sûr d'avoir bien saisie le but (y'a des choses qui me paraissent bien lourdes).

Je pense que ton problème vient du fait que tes paramètres sont transmis ByVal par défaut, ce qui veux dire que le variant plsDest que tu transmets à ta Procédure similarite_rmult_multiple et transmis en lecture seule, donc peut importe les modifications que tu lui apportes, elles ne sont pas prises en compte, il faut préciser ByRef à mon avis.

[Edit]J'ai modifié le code qui suit [/Edit]

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
Sub Calcul(Param1 As Range, ByVal Param2 As Variant, ByRef Param3 As Variant)
 
  'Tu redimensionnes
  'ReDim Param3(LBound(Param2), UBound(Param2)) '
  Param3 = Array(..) ou Param3=Param2 pour avoir la même structure
  ' [...]
End Sub
 
Sub Proc2()
Dim TabRetour As Variant
 
  'Appel de Proc1
  MonParam1 = array(....)
  Proc MonRange, MonParam1, TabRetour
End Sub

Tu peux aussi utiliser une fonction au lieu d'une procédure et lui faire retourner ton tableau

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
Function CalulBis(Param1 As Range, ByVal Param2 As Variant) As variant
Dim MonTab As Variant
 
  MonTab = Array(...)
  '[...]
 
  CalculBis = MonTab
End Function
 
Sub Proc2Bis()
Dim TabRetour As Variant
Dim unRet As Variant
 
  TabRetour = CalculBis(MonRange, MonParam1)
 
  For Each unRet In TabRetour
    [...]
  Next
End Sub

++
Qwaz

**jpvba** · 12/05/2025, 22h55

Re-Bonjour,

J'arrive maintenant aux codes suivants :

Première colonne afin d'avoir le pourcentage

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
Sub similarite_rmult2(plListe As Range, plageRech As Range, plageRecup As Range, plDest As Range, seuil As Double)
 
    Dim rech As Variant, recup As Variant, liste As Variant
    Dim dict As Object
    Dim i As Long
    Dim valListe As String, matches As String
    Dim sim As Double
    Dim resultat() As Variant
    Dim cle As Variant
 
 
    ' Chargement des plages dans des tableaux
    rech = plageRech.Value2
    recup = plageRecup.Value2
    liste = plListe.Value2
 
    Set dict = CreateObject("Scripting.Dictionary")
 
    ' Remplissage du dictionnaire avec gestion des doublons
    For i = 1 To UBound(rech, 1)
        Dim cleTemp As String: cleTemp = CStr(rech(i, 1))
        If dict.Exists(cleTemp) Then
            dict(cleTemp) = dict(cleTemp) & vbLf & recup(i, 1)
        Else
            dict.Add cleTemp, recup(i, 1)
        End If
    Next i
 
    ' Préparation du tableau de résultats
    ReDim resultat(1 To UBound(liste, 1), 1 To 1)
 
    ' Recherche de similarités multiples avec tri décroissant
    For i = 1 To UBound(liste, 1)
        valListe = CStr(liste(i, 1))
        matches = ""
 
        Dim tempMatches() As Variant
        Dim tempIndex As Long
        tempIndex = -1
 
        For Each cle In dict.keys
            sim = SimilaritePourcent(valListe, CStr(cle))
            If sim >= seuil Then
                Dim lignes() As String: lignes = Split(dict(cle), vbLf)
                Dim l As Variant
                For Each l In lignes
                    tempIndex = tempIndex + 1
                    ReDim Preserve tempMatches(0 To tempIndex)
                    tempMatches(tempIndex) = Array(l, sim)
                Next l
            End If
        Next cle
 
        If tempIndex >= 0 Then
            ' Tri du tableau tempMatches par ordre décroissant de similarité
            Dim j As Long, k As Long
            Dim tmp As Variant
            For j = 0 To tempIndex - 1
                For k = j + 1 To tempIndex
                    If tempMatches(j)(1) < tempMatches(k)(1) Then
                        tmp = tempMatches(j)
                        tempMatches(j) = tempMatches(k)
                        tempMatches(k) = tmp
                    End If
                Next k
            Next j
 
            ' Construire la chaîne triée
            For j = 0 To tempIndex
                matches = matches & tempMatches(j)(0) & " - " & Format(tempMatches(j)(1), "0") & "%" & vbLf
            Next j
 
            ' Supprimer le dernier retour à la ligne
            If Right(matches, 1) = vbLf Then matches = Left(matches, Len(matches) - 1)
            resultat(i, 1) = matches
        Else
            resultat(i, 1) = "Aucune correspondance"
        End If
    Next i
 
    ' Écriture des résultats
    plDest.Resize(UBound(resultat, 1), 1).Value = resultat
 
End Sub

Pour les colonnes suivantes (sans le pourcentage)

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
Sub similarite_rmult_multiple(plListe As Range, plageRech As Range, plagesRecup() As Variant, plsDest() As Variant, seuil As Double)
    Dim rech As Variant, recups() As Variant, liste As Variant
    Dim dicts() As Object
    Dim i As Long, j As Long
    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
 
 
    ' 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) & 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

COde de définition des range

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
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
Sub soumission_comparaison_similarite2()
 
    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 resSoum()
    Dim resTrav()
 
    Dim seuil As Double
 
    Dim start As Single
    Dim finish As Single
 
    start = Timer
 
    Application.ScreenUpdating = False
 
 
'On Error GoTo errorhandler:
 
 
   ' Saisie 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
 
    '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
 
     resSoum = Array(PlageSoumission_Desc_prov, PlageSoumission_No_famille, PlageSoumission_No_classe, _
                     PlageSoumission_No_groupe, PlageSoumission_No_ss_groupe, PlageSoumission_Statut)
 
 
'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
 
    resTrav = Array(PlageTravail_LettreDescr_trouve, PlageTravail_LettreF_trouve, PlageTravail_LettreC_trouve, _
                    PlageTravail_LettreG_trouve, PlageTravail_LettreSG_trouve, PlageTravail_LettreStatut_trouve)
 
 
'faire rmult_dico afin d'avoir les P_trouvés
 
    similarite_rmult2 PlageTravail_Code, PlageSoumission_No_manuf, PlageSoumission_No_item, PlageTravail_LettreP_trouve, seuil
 
    similarite_rmult_multiple PlageTravail_Code, PlageSoumission_No_manuf, resSoum, resTrav, seuil
 
 
Application.ScreenUpdating = True
 
 
finish = Timer
MsgBox "durée du traitement: " & finish - start & " secondes"
 
Exit Sub
 
errorhandler: MsgBox "cliquer sur le bouton update !!!"
 
End Sub

Le temps d'exécution est cependant long. Le but est de trouvé par code si un produit à déjà été soumis dans le passé. Je veux y aller par similarité. Pour le premier élément, il en convient je dois y aller par similarité mais les autres donnée (ceux demander par

similarite_rmult_multiple PlageTravail_Code, PlageSoumission_No_manuf, resSoum, resTrav, seuil

. Je pourrais y aller par exactitude, ce qui gagnerais un temps phénoménale.

J'ai présentement une fonction similaire à recherchev mais qui trouve toute les possibilités et retournant le tout en ajoutant un retour de ligne. Le seul hic que j'ai présentement, c'Est qu'il cherche le contenu d'une cellule et avec ce que j'ai, j'ai plusieurs éléments.

Je ne sais pas si il serait possible au lieu de créer une ligne pour chacun des éléments au lieu d'un retour. J'exécuterais ma fonction similaire à la recherchev et bingo, ça serais plus rapide.

**Nain porte koi** · 12/05/2025, 23h26

Envoyé par jpvba

Le temps d'exécution est cependant long

Sans un fichier pour tester on ne peut pas savoir ce que "long" veut dire

**jpvba** · 13/05/2025, 00h15

Mon fichier compresser prend 21,9 mo ... je vais essayé de trouvé une façon de vous l'envoyer demain.

Pour le long, je parle de 8 minutes afin de vous donner une idée de grandeur

**Qwazerty** · 13/05/2025, 08h00

Salut

Nain porte koi à raison,à minima il faudrait que l'on comprenne comment est structuré ton tableau, inutile qu'on est la totalité des données (21Mo, c'est quand même énorme pour un xlsm). Et surtout comprendre ce que vous voulez faire exactement, donner le code est une chose mais le comprendre en est une autre.

Y'a par exemple une fonction qui permet de récupérer la lettre d'une colonne et que tu ne fourni pas. Quel est le but? Pourquoi ne pas simplement récupérer l'index de la colonne ? A moins qu'il ne s'agisse pas de la lettre au niveau des entêtes mais une lettre incluse dans tes données?

J'ai modifié le code que j'avais posté, j'ai fait une erreur de redimensionnement.
~~Je suis étonné que ton code ne provoque pas une erreur en plaçant des variables tableau ouvert dans les paramètres de la procédure.~~

[Edit]
J'ai refait les codes pour qu'ils soient plus explicites. Tu as 3 cas de figure différents qui te permette un retour de données sous forme de tableau

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
Sub Inversion(ByVal tabEnvoi As Variant, ByRef tabRetour As Variant)
Dim i As Integer, iMax As Integer
 
  'On fait une copie du tableau dans le tableau retour pour copier sa structure
  tabRetour = tabEnvoi
 
  'On inverse le contenu (je simplifie mais il faudrait tenir compte de lbound(tabEnvoi) dans la suite)
  iMax = UBound(tabEnvoi)
  For i = 0 To iMax
    tabRetour(i) = tabEnvoi(iMax - i)
  Next
 
  ' [...]
End Sub
 
Sub Test_Inversion()
Dim tabRetour As Variant
Dim tabEnvoi As Variant
 
  tabEnvoi = Array("A", "B", "C")
 
  'Appel de Proc1
  Inversion tabEnvoi, tabRetour
End Sub
 
 
Function Fct_Inversion(ByVal tabEnvoi As Variant) As Variant
Dim i As Integer, iMax As Integer
Dim tabTmp As Variant
 
  'On fait une copie du tableau dans le tableau retour pour copier sa structure
  tabTmp = tabEnvoi
 
  'On inverse le contenu je simplifie mais il faudrait tenir compte de lbound(tabEnvoi) dans la suite)
  iMax = UBound(tabEnvoi)
  For i = 0 To iMax
    tabTmp(i) = tabEnvoi(iMax - i)
  Next
 
  'On retourne la tableu
  Fct_Inversion = tabTmp
 
  ' [...]
End Function
 
Sub Test_Fct_Inversion()
Dim tabRetour As Variant
Dim tabEnvoi As Variant
 
  tabEnvoi = Array("A", "B", "C")
 
  'Appel de Proc1
  tabRetour = Fct_Inversion(tabEnvoi)
End Sub
 
 
 
Sub InversionTab(tabEnvoi() As Variant, tabRetour() As Variant)
Dim i As Integer, iMax As Integer
 
  'On fait en sorte d'avoir la même structure
  ReDim tabRetour(LBound(tabEnvoi) To UBound(tabEnvoi))
 
  'On inverse le contenu (je simplifie mais il faudrait tenir compte de lbound(tabEnvoi) dans la suite)
  iMax = UBound(tabEnvoi)
  For i = 0 To iMax
    tabRetour(i) = tabEnvoi(iMax - i)
  Next
 
End Sub
 
 
Sub Test_InversionTab()
Dim tabEnvoi() As Variant, tabRetour() As Variant
 
ReDim tabEnvoi(0 To 2)
tabEnvoi(0) = "A"
tabEnvoi(1) = "B"
tabEnvoi(2) = "C"
 
InversionTab tabEnvoi, tabRetour
End Sub

J'en ai profiter pour aussi remettre au clair dans ma tête le ByVal ByRef dans le casde figure ou tu transmets des tableaux déclarés ouverts VariableTab(). En fait par défaut c'est en ByRef... Donc je ne saisi par ce qui t'empêche de retourner ton tableau avec la dimension souhaité.

Par contre, il faut bien en tenir compte dans les deux autres cas de figure, sinon, ton tableau retour sera retourné vide (car en lecture seule)
[/Edit]

++
Qwaz

retour de plusieurs informations au lieu de 1 [XL-365]

Macros et VBA Excel

Vue hybride

Discussions similaires

Partager

Partager