Discussion :

[jpvba]

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]

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]

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]

Le temps d'exécution est cependant long

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

[jpvba]

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]

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

[jpvba]

Bonjour à vous,

Je vais essayé de vous éclairé le plus possible. Je ne comprends pas ce que vous insinuez par la structure. Si vous voulez, je peux faire un imprime écran du dit fichier.

Présentement, j'utilise le fichier comme outil que je donne à des gens n'ayant pas nécessaire des "bonnes pratiques". Ils ont tendance à ajouter des colonnes, renommer des champs, bouger des colonnes, etc ... J'utilise donc du code afin de déterminer le nom et l'emplacement de colonne sauf pour une feuille auquel les gens n'ont pas d'accès. Oui, à première vue, c'est compliquer mais j'ai disons sauvé pas mal de maux de tête en utilisant cette façon de faire. Cette outil permet de comparer des codes exacts, ce qui est limités. BEaucoup de distributeur utilise des préfixe et suffixe du code maufacturier et parfois c'est le manufacturier que nous avons comme code.

Donc en bon Français, j'essaie de faire un espèce de fuzzy lookup (qui est trop compliqué à utilisé pour la plupart des gens utilisant l'outil) afin de voir la correspondance entre un code interne et des codes externes afin d'augmenter les correspondances potentiels. Par la suite, je remplis des informations facilitant leur choix sur la conformité des informations retournés et sur l'élaboration de demande de création de produit. Il n'y a pas de structure, d'uniformité sur les code externes donc, une tomate pourrais avoir le même code qu'un médicament. Je leur pousse alors la descriptions concernant le code, et des outils de classification.

Possiblement, vous vous dites que d'utiliser les outils de classifications pourrait réduire le nombre de données dans la plage à chercher. Effectivement, cela pourrais aidé mais il y a plusieurs scénario possible car il y a des faiblesses dans la classifications. Il se peut, dans le projet en cours, qu'il y ait plusieurs classification ou tout simplement que l'utilisateur ne comprends pas ce système. J'ai pensé de faire un userform afin de simplifier le travail mais je ne suis pas sur que cela pourra fonctionner étant donner que le code n'est pas dans le fichier même mais dans un emplacement réseau décloisonner (il y a des contraintes informatiques auxquels je ne peux détourner et que parfois je trouve plus paranoïaque qu'efficace)

LA chose que je peux faire (ce que j'ai mentionné antérieurement) c'est d'utiliser une recherchev ou une de ses dérivés qui permettrais alors de sauter l'étape de similarité car ceux-ci sont rattaché au produit.

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
Sub rmult_dico(plListe As Range, plageRech As Range, plageRecup As Range, plDest As Range)
 
    Dim rech, recup, liste
    Dim dict, lig As Long
 
    rech = plageRech.Value
    recup = plageRecup.Value
    liste = plListe.Value
 
    Set dict = CreateObject("Scripting.Dictionary")
 
    For lig = 1 To UBound(rech)
        If dict.Exists(rech(lig, 1)) Then
            dict(rech(lig, 1)) = dict(rech(lig, 1)) & vbLf & recup(lig, 1)
        Else
            dict(rech(lig, 1)) = recup(lig, 1)
        End If
    Next lig
 
    If IsArray(liste) Then
        For lig = 1 To UBound(liste)
            liste(lig, 1) = dict(liste(lig, 1))
        Next lig
        plDest = liste
    Else
        plDest = dict(plListe.Value)
    End If
 
End Sub

C'Est sois que je modifie ce code qui pourrait rechercher chacun des éléments dans une cellule, ce que je ne sais pas si c'est faisable, viable, une bonne idée ou de ne plus utiliser le vblf (retour de ligne) et faire une création de ligne. Étant donné que chaqu'une des lignes à une seul et unique information, je pourrais faire la recherchev et gagné du temps.

[Qwazerty]

Salut

Je n'ai pas tout lu, je dois partir.

Mais pour le début, je dirais deux choses

1. Pour ce qui est de colonnes déplacer masquées,... le mieux c'est de fonctionner avec un tableau structuré, comme ça ils peuvent décaler les colonnes, dans le code VBA il suffit de les appeler par leurs noms.
2. Pour ce qui est des codes avec correspondance partielle, je pense que Power Query serait d'une grande aide. Il y a dans la fonction Join (requeter) il me semble, la possibilité de faire des correspondances entre deux colonne avec un taux de ressemblance. Je pense que ça correspond au besoin. Il suffirait d'importer les données des deux tables dans PQ, puis faire le Join entre les deux par correspondance (partielle si besoin) entre les colonnes des deux tables.

++
Qwaz

[Nain porte koi]

Moi j'ai tout lu mais je reste sur

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

d'autant qu'il semblerait que le problème soit largement plus complexe qu'une simple lenteur

[jpvba]

Voici donc après plusieurs test, ce que j'arrive comme code

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
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
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
    Dim LettreSimilar As String
    Dim LettreCode_trouve As String
    Dim LettreFormat_Trouve As String
 
    LettreCode = TrouveLettreColonne([code_distr])
    LettreCode_trouve = TrouveLettreColonne([code_trouve])
    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])
    LettreSimilar = TrouveLettreColonne([similar])
    LettreFormat_Trouve = TrouveLettreColonne([format_trouve])
 
    Dim PlageTravail_Code As Range
    Dim PlageTravail_Code_Trouve As Range
    Dim PlageTravail_LettreP_trouve As Range
    Dim PlageTravail_LettreSimilar 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 PlageTravail_LettreFormat_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 PlageSoumission_Tout As Range
 
    Dim PlageCatalogue_Tout As Range
 
    Dim PlageRes_Code_Cherche As Range
    Dim PlageRes_Code_Trouve As Range
    Dim PlageRes_Valeur As Range
    Dim PlageRes_Pour100 As Range
    Dim PlageRes_Prov As Range
    Dim PlageRes_F As Range
    Dim PlageRes_C As Range
    Dim PlageRes_G As Range
    Dim PlageRes_SG As Range
    Dim PlageRes_Statut As Range
    Dim PlageRes_Format As Range
 
    Dim start As Single
    Dim finish As Single
 
    Dim seuil As Double
 
    Dim derLigne As Long
 
    start = Timer
 
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
 
 
    On Error GoTo errorhandler:
 
'si il n'y a pas de feuille soumisson ou catalogue, on demande de faire un update
 
    If sheetExists("soumission") = False Or sheetExists("catalogue") = False Then
 
        MsgBox "cliquer sur le bouton update !!!"
        Exit Sub
 
    End If
 
'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 ajoute une valeur afin de bypassé le minimum de 2 code différents
 
 Worksheets("Travail").Range(LettreCode & LastLignUsedInSheet_Column("Travail", LettreCode) + 1) = "ajoutbidondedonne"
 
 
'on détruit la feuille resultats si il y en a déjà une
 
   If sheetExists("resultats") Then Sheets("resultats").Delete
 
 
'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
 
 
'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) + 1)
    Set PlageTravail_Code_Trouve = .Range(LettreCode_trouve & 2, LettreCode_trouve & LastLignUsedInSheet_Column("Travail", LettreCode_trouve) + 1)
    Set PlageTravail_LettreP_trouve = .Range(LettreP_trouve & 2, LettreP_trouve & LastLignUsedInSheet_Column("Travail", LettreP_trouve) + 1)
    Set PlageTravail_LettreSimilar = .Range(LettreSimilar & 2, LettreSimilar & LastLignUsedInSheet_Column("Travail", LettreSimilar) + 1)
    Set PlageTravail_LettreDescr_trouve = .Range(LettreDescr_trouve & 2, LettreDescr_trouve & LastLignUsedInSheet_Column("Travail", LettreDescr_trouve) + 1)
    Set PlageTravail_LettreF_trouve = .Range(LettreF_trouve & 2, LettreF_trouve & LastLignUsedInSheet_Column("Travail", LettreF_trouve) + 1)
    Set PlageTravail_LettreC_trouve = .Range(LettreC_trouve & 2, LettreC_trouve & LastLignUsedInSheet_Column("Travail", LettreC_trouve) + 1)
    Set PlageTravail_LettreG_trouve = .Range(LettreG_trouve & 2, LettreG_trouve & LastLignUsedInSheet_Column("Travail", LettreG_trouve) + 1)
    Set PlageTravail_LettreSG_trouve = .Range(LettreSG_trouve & 2, LettreSG_trouve & LastLignUsedInSheet_Column("Travail", LettreSG_trouve) + 1)
    Set PlageTravail_LettreStatut_trouve = .Range(LettreStatut_trouve & 2, LettreStatut_trouve & LastLignUsedInSheet_Column("Travail", LettreStatut_trouve) + 1)
    Set PlageTravail_LettreFormat_trouve = .Range(LettreFormat_Trouve & 2, LettreFormat_Trouve & LastLignUsedInSheet_Column("Travail", LettreFormat_Trouve) + 1)
 
 
    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"))
 
    Set PlageSoumission_Tout = .Range("B2:H" & LastLignUsedInSheet_Column("soumission", "A"))
 
    End With
 
'on set les range afin de faciliter la rmult_dico_unique et le vlookup
 
    Set PlageCatalogue_Tout = Worksheets("Catalogue").Range("A2:W" & LastLignUsedInSheet("catalogue"))
 
 
'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_Code_Trouve, PlageTravail_LettreP_trouve, _
          PlageTravail_LettreDescr_trouve, PlageTravail_LettreSimilar, _
          PlageTravail_LettreFormat_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
 
    Dim valeursNettoyees() As String
    ReDim valeursNettoyees(1 To UBound(TblBD1))
 
    For i = 1 To UBound(TblBD1)
 
                clé = CleanTrim(TblBD1(i, 1))
                Dico(clé) = clé
                valeursNettoyees(i) = clé
 
    Next i
 
Sheets("Travail").Range(LettreCode & 2).Resize(UBound(valeursNettoyees)) = Application.Transpose(valeursNettoyees)
 
Else
 
    Cells(2, LettreCode) = CleanTrim(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_Code_Trouve = .Range(LettreCode_trouve & 2, LettreCode_trouve & LastLignUsedInSheet_Column("Travail", LettreCode))
    Set PlageTravail_LettreP_trouve = .Range(LettreP_trouve & 2, LettreP_trouve & LastLignUsedInSheet_Column("Travail", LettreCode))
    Set PlageTravail_LettreSimilar = .Range(LettreSimilar & 2, LettreSimilar & 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 PlageTravail_LettreFormat_trouve = .Range(LettreFormat_Trouve & 2, LettreFormat_Trouve & LastLignUsedInSheet_Column("Travail", LettreCode))
 
End With
 
'creation de la feuille resultats
 
    Sheets.Add.Name = "resultats"
 
 
'faire la similarité afin d'avoir la feuille resultats
 
    similarite_rmult PlageTravail_Code, PlageSoumission_No_manuf, PlageSoumission_No_item, seuil
 
 
 With Worksheets("resultats")
 
'on nomme les plages déjà présente
 
 
    Set PlageRes_Code_Cherche = .Range("A2:a" & LastLignUsedInSheet_Column("resultats", "a"))
    Set PlageRes_Code_Trouve = .Range("b2:b" & LastLignUsedInSheet_Column("resultats", "a"))
    Set PlageRes_Valeur = .Range("c2:c" & LastLignUsedInSheet_Column("resultats", "a"))
    Set PlageRes_Pour100 = .Range("d2:d" & LastLignUsedInSheet_Column("resultats", "a"))
    Set PlageRes_Prov = .Range("e2:e" & LastLignUsedInSheet_Column("resultats", "a"))
    Set PlageRes_F = .Range("f2:f" & LastLignUsedInSheet_Column("resultats", "a"))
    Set PlageRes_C = .Range("g2:g" & LastLignUsedInSheet_Column("resultats", "a"))
    Set PlageRes_G = .Range("h2:h" & LastLignUsedInSheet_Column("resultats", "a"))
    Set PlageRes_SG = .Range("i2:i" & LastLignUsedInSheet_Column("resultats", "a"))
    Set PlageRes_Statut = .Range("j2:j" & LastLignUsedInSheet_Column("resultats", "a"))
    Set PlageRes_Format = .Range("k2:k" & LastLignUsedInSheet_Column("resultats", "a"))
 
 
'on nomme les colonnes manquante de la feuille resultats
 
 
    .Cells(1, 5).Value = "Desc_prov"
    .Cells(1, 6).Value = "No_famille"
    .Cells(1, 7).Value = "No_classe"
    .Cells(1, 8).Value = "No_groupe"
    .Cells(1, 9).Value = "No_ss_groupe"
    .Cells(1, 10).Value = "statut"
    .Cells(1, 11).Value = "format"
 
 
 End With
 
'on fait les recherchev sur les colonnes de la feuille resultats
 
    PlageRes_Prov = Application.WorksheetFunction.VLookup(PlageRes_Valeur, PlageSoumission_Tout, 2, False)
 
    PlageRes_F = Application.WorksheetFunction.VLookup(PlageRes_Valeur, PlageSoumission_Tout, 3, False)
 
    PlageRes_C = Application.WorksheetFunction.VLookup(PlageRes_Valeur, PlageSoumission_Tout, 4, False)
 
    PlageRes_G = Application.WorksheetFunction.VLookup(PlageRes_Valeur, PlageSoumission_Tout, 5, False)
 
    PlageRes_SG = Application.WorksheetFunction.VLookup(PlageRes_Valeur, PlageSoumission_Tout, 6, False)
 
    PlageRes_Statut = Application.WorksheetFunction.VLookup(PlageRes_Valeur, PlageSoumission_Tout, 7, False)
 
    PlageRes_Format = Application.WorksheetFunction.VLookup(PlageRes_Valeur, PlageCatalogue_Tout, 13, False)
 
 
 
'on fait les rmult pour peupler la feuille Travail
 
    rmult_dico PlageTravail_Code, PlageRes_Code_Cherche, PlageRes_Code_Trouve, PlageTravail_Code_Trouve
 
    rmult_dico PlageTravail_Code, PlageRes_Code_Cherche, PlageRes_Valeur, PlageTravail_LettreP_trouve
 
    rmult_dico PlageTravail_Code, PlageRes_Code_Cherche, PlageRes_Pour100, PlageTravail_LettreSimilar
 
    rmult_dico PlageTravail_Code, PlageRes_Code_Cherche, PlageRes_Prov, PlageTravail_LettreDescr_trouve
 
    rmult_dico PlageTravail_Code, PlageRes_Code_Cherche, PlageRes_F, PlageTravail_LettreF_trouve
 
    rmult_dico PlageTravail_Code, PlageRes_Code_Cherche, PlageRes_C, PlageTravail_LettreC_trouve
 
    rmult_dico PlageTravail_Code, PlageRes_Code_Cherche, PlageRes_G, PlageTravail_LettreG_trouve
 
    rmult_dico PlageTravail_Code, PlageRes_Code_Cherche, PlageRes_SG, PlageTravail_LettreSG_trouve
 
    rmult_dico PlageTravail_Code, PlageRes_Code_Cherche, PlageRes_Statut, PlageTravail_LettreStatut_trouve
 
    rmult_dico PlageTravail_Code, PlageRes_Code_Cherche, PlageRes_Format, PlageTravail_LettreFormat_trouve
 
 
'on détruit la feuille resultats
Sheets("resultats").Delete
 
 
'on détruit la ligne de code bidon du bypass
 
derLigne = Worksheets("Travail").Cells(Worksheets("Travail").Rows.Count, 1).End(xlUp).Row
 
Worksheets("Travail").Rows(derLigne).Delete
 
 
 
 
Application.ScreenUpdating = True
Application.DisplayAlerts = True
 
 
finish = Timer
MsgBox "durée du traitement: " & finish - start & " secondes"
 
Exit Sub
 
errorhandler: MsgBox "cliquer sur le bouton update !!!"
 
End Sub

MEs lenteurs sont attribué à la plage de recherche contenant environ 500 000 lignes. Il est fort possible que je vais éventuellement demander avec un userform des question afin de pouvoir faire des filtres afin de gagner de la vitesse

[Nain porte koi]

Re,

je ne sais pas ce que fait la fonction LastLignUsedInSheet_Column mais au lieu de l'appeler N fois vous pourriez mettre son contenu dans une variable une bonne fois pour toutes

Exemple : ligne 155 et suivantes remplacer & LastLignUsedInSheet_Column("soumission", "A") par la variable

[Qwazerty]

Salut

Explique nous ce que tu veux faire avec un fichier demo. Sinon, on peut passer des lustres à chercher ce qu'il faut modifier pour grappiller des millisecondes, alors que si ça se trouve, on peut te proposer un solution qui sera de base plus rapide.

++
Qwaz

[jpvba]

Re-Bonjour,

Afin de gagné du temps, je lance un userform permettant à l'utilisateur de choisir des option de filtration.

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
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
Option Explicit
 
Sub test_combo_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
    Dim LettreSimilar As String
    Dim LettreCode_trouve As String
    Dim LettreFormat_Trouve As String
 
    LettreCode = TrouveLettreColonne([code_distr])
    LettreCode_trouve = TrouveLettreColonne([code_trouve])
    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])
    LettreSimilar = TrouveLettreColonne([similar])
    LettreFormat_Trouve = TrouveLettreColonne([format_trouve])
 
    Dim PlageTravail_Code As Range
    Dim PlageTravail_Code_Trouve As Range
    Dim PlageTravail_LettreP_trouve As Range
    Dim PlageTravail_LettreSimilar 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 PlageTravail_LettreFormat_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 PlageSoumission_Tout As Range
 
    Dim PlageCatalogue_Tout As Range
 
    Dim PlageRes_Code_Cherche As Range
    Dim PlageRes_Code_Trouve As Range
    Dim PlageRes_Valeur As Range
    Dim PlageRes_Pour100 As Range
    Dim PlageRes_Prov As Range
    Dim PlageRes_F As Range
    Dim PlageRes_C As Range
    Dim PlageRes_G As Range
    Dim PlageRes_SG As Range
    Dim PlageRes_Statut As Range
    Dim PlageRes_Format As Range
 
    Dim start As Single
    Dim finish As Single
 
    Dim seuil As Double
 
    Dim derLigne As Long
 
    Dim wsFiltre As Worksheet
 
    Dim wsSoum As Worksheet
    Set wsSoum = Worksheets("soumission")
 
    Dim lastRow As Long
 
 
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
 
 
    On Error GoTo errorhandler:
 
'si il n'y a pas de feuille soumisson ou catalogue, on demande de faire un update
 
    If sheetExists("soumission") = False Or sheetExists("catalogue") = False Then
 
        MsgBox "cliquer sur le bouton update !!!"
        Exit Sub
 
    End If
 
'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 ajoute une valeur afin de bypassé le minimum de 2 code différents
 
 Worksheets("Travail").Range(LettreCode & LastLignUsedInSheet_Column("Travail", LettreCode) + 1) = "ajoutbidondedonne"
 
 
'on détruit la feuille resultats si il y en a déjà une
 
   If sheetExists("resultats") Then Sheets("resultats").Delete
 
 
'on détruit la feuille soumission_filtrée si il y en a déjà une
 
   If sheetExists("soumission_filtrée") Then Sheets("soumission_filtrée").Delete
 
 
'on détruit la feuille Filtre si il y en a déjà une
 
   If sheetExists("Filtre") Then Sheets("Filtre").Delete
 
 
'on crée la feuille filtre
 
    Set wsFiltre = Worksheets.Add
    wsFiltre.Name = "Filtre"
 
 
' on fais l'entête de la feuille filtre
 
    With wsFiltre
 
        .Range("A1").Value = wsSoum.Range("D1").Value ' Famille
        .Range("B1").Value = wsSoum.Range("E1").Value ' Classe
 
    End With
 
 
'Entrée et validation du seuil
 
    FiltreSoum.Show
 
    seuil = FiltreSoum.txtPourcent.Value
 
 
'on ommence la minuterie une fois que les sélections sont faites par l'utilisateur
 
    start = Timer
 
'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) + 1)
    Set PlageTravail_Code_Trouve = .Range(LettreCode_trouve & 2, LettreCode_trouve & LastLignUsedInSheet_Column("Travail", LettreCode_trouve) + 1)
    Set PlageTravail_LettreP_trouve = .Range(LettreP_trouve & 2, LettreP_trouve & LastLignUsedInSheet_Column("Travail", LettreP_trouve) + 1)
    Set PlageTravail_LettreSimilar = .Range(LettreSimilar & 2, LettreSimilar & LastLignUsedInSheet_Column("Travail", LettreSimilar) + 1)
    Set PlageTravail_LettreDescr_trouve = .Range(LettreDescr_trouve & 2, LettreDescr_trouve & LastLignUsedInSheet_Column("Travail", LettreDescr_trouve) + 1)
    Set PlageTravail_LettreF_trouve = .Range(LettreF_trouve & 2, LettreF_trouve & LastLignUsedInSheet_Column("Travail", LettreF_trouve) + 1)
    Set PlageTravail_LettreC_trouve = .Range(LettreC_trouve & 2, LettreC_trouve & LastLignUsedInSheet_Column("Travail", LettreC_trouve) + 1)
    Set PlageTravail_LettreG_trouve = .Range(LettreG_trouve & 2, LettreG_trouve & LastLignUsedInSheet_Column("Travail", LettreG_trouve) + 1)
    Set PlageTravail_LettreSG_trouve = .Range(LettreSG_trouve & 2, LettreSG_trouve & LastLignUsedInSheet_Column("Travail", LettreSG_trouve) + 1)
    Set PlageTravail_LettreStatut_trouve = .Range(LettreStatut_trouve & 2, LettreStatut_trouve & LastLignUsedInSheet_Column("Travail", LettreStatut_trouve) + 1)
    Set PlageTravail_LettreFormat_trouve = .Range(LettreFormat_Trouve & 2, LettreFormat_Trouve & LastLignUsedInSheet_Column("Travail", LettreFormat_Trouve) + 1)
 
 
    Set Dico = CreateObject("Scripting.Dictionary")
    TblBD1 = .Range(LettreCode & 2, LettreCode & LastLignUsedInSheet_Column("Travail", LettreCode))
 
 
    End With
 
 
' Copier les lignes filtrées vers une nouvelle feuille
Dim nbCritLignes As Long
nbCritLignes = wsFiltre.Cells(wsFiltre.Rows.Count, 1).End(xlUp).Row
 
wsSoum.Range("A1:H" & LastLignUsedInSheet("soumission")).AdvancedFilter _
    Action:=xlFilterCopy, _
    CriteriaRange:=wsFiltre.Range("A1:B" & nbCritLignes), _
    CopyToRange:=wsSoum.Range("J1"), _
    Unique:=False
 
 
' Copier les résultats filtrés dans une nouvelle feuille "soumission_filtrée"
Sheets.Add(after:=Sheets("soumission")).Name = "soumission_filtrée"
Sheets("soumission").Range("J1").CurrentRegion.Copy Destination:=Sheets("soumission_filtrée").Range("A1")
Sheets("soumission").Range("J1").CurrentRegion.Clear
 
 
' Utiliser cette feuille dans les plages suivantes
With Worksheets("soumission_filtrée")
 
    Set PlageSoumission_No_manuf = .Range("A2:A" & LastLignUsedInSheet_Column("soumission_filtrée", "A"))
    Set PlageSoumission_No_item = .Range("B2:B" & LastLignUsedInSheet_Column("soumission_filtrée", "A"))
    Set PlageSoumission_Desc_prov = .Range("C2:C" & LastLignUsedInSheet_Column("soumission_filtrée", "A"))
    Set PlageSoumission_No_famille = .Range("D2:D" & LastLignUsedInSheet_Column("soumission_filtrée", "A"))
    Set PlageSoumission_No_classe = .Range("E2:E" & LastLignUsedInSheet_Column("soumission_filtrée", "A"))
    Set PlageSoumission_No_groupe = .Range("F2:F" & LastLignUsedInSheet_Column("soumission_filtrée", "A"))
    Set PlageSoumission_No_ss_groupe = .Range("G2:G" & LastLignUsedInSheet_Column("soumission_filtrée", "A"))
    Set PlageSoumission_Statut = .Range("H2:H" & LastLignUsedInSheet_Column("soumission_filtrée", "A"))
    Set PlageSoumission_Tout = .Range("B2:H" & LastLignUsedInSheet_Column("soumission_filtrée", "A"))
 
End With
 
 
 
'on set les range afin de faciliter la rmult_dico_unique et le vlookup
 
    Set PlageCatalogue_Tout = Worksheets("Catalogue").Range("A2:W" & LastLignUsedInSheet("catalogue"))
 
 
'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_Code_Trouve, PlageTravail_LettreP_trouve, _
          PlageTravail_LettreDescr_trouve, PlageTravail_LettreSimilar, _
          PlageTravail_LettreFormat_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
 
    Dim valeursNettoyees() As String
    ReDim valeursNettoyees(1 To UBound(TblBD1))
 
    For i = 1 To UBound(TblBD1)
 
                clé = CleanTrim(TblBD1(i, 1))
                Dico(clé) = clé
                valeursNettoyees(i) = clé
 
    Next i
 
Sheets("Travail").Range(LettreCode & 2).Resize(UBound(valeursNettoyees)) = Application.Transpose(valeursNettoyees)
 
Else
 
    Cells(2, LettreCode) = CleanTrim(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_Code_Trouve = .Range(LettreCode_trouve & 2, LettreCode_trouve & LastLignUsedInSheet_Column("Travail", LettreCode))
    Set PlageTravail_LettreP_trouve = .Range(LettreP_trouve & 2, LettreP_trouve & LastLignUsedInSheet_Column("Travail", LettreCode))
    Set PlageTravail_LettreSimilar = .Range(LettreSimilar & 2, LettreSimilar & 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 PlageTravail_LettreFormat_trouve = .Range(LettreFormat_Trouve & 2, LettreFormat_Trouve & LastLignUsedInSheet_Column("Travail", LettreCode))
 
End With
 
'creation de la feuille resultats
 
    Sheets.Add.Name = "resultats"
 
 
'faire la similarité afin d'avoir la feuille resultats
 
    similarite_rmult PlageTravail_Code, PlageSoumission_No_manuf, PlageSoumission_No_item, seuil
 
 
 With Worksheets("resultats")
 
'on nomme les plages déjà présente
 
 
    Set PlageRes_Code_Cherche = .Range("A2:a" & LastLignUsedInSheet_Column("resultats", "a"))
    Set PlageRes_Code_Trouve = .Range("b2:b" & LastLignUsedInSheet_Column("resultats", "a"))
    Set PlageRes_Valeur = .Range("c2:c" & LastLignUsedInSheet_Column("resultats", "a"))
    Set PlageRes_Pour100 = .Range("d2:d" & LastLignUsedInSheet_Column("resultats", "a"))
    Set PlageRes_Prov = .Range("e2:e" & LastLignUsedInSheet_Column("resultats", "a"))
    Set PlageRes_F = .Range("f2:f" & LastLignUsedInSheet_Column("resultats", "a"))
    Set PlageRes_C = .Range("g2:g" & LastLignUsedInSheet_Column("resultats", "a"))
    Set PlageRes_G = .Range("h2:h" & LastLignUsedInSheet_Column("resultats", "a"))
    Set PlageRes_SG = .Range("i2:i" & LastLignUsedInSheet_Column("resultats", "a"))
    Set PlageRes_Statut = .Range("j2:j" & LastLignUsedInSheet_Column("resultats", "a"))
    Set PlageRes_Format = .Range("k2:k" & LastLignUsedInSheet_Column("resultats", "a"))
 
 
'on nomme les colonnes manquante de la feuille resultats
 
 
    .Cells(1, 5).Value = "Desc_prov"
    .Cells(1, 6).Value = "No_famille"
    .Cells(1, 7).Value = "No_classe"
    .Cells(1, 8).Value = "No_groupe"
    .Cells(1, 9).Value = "No_ss_groupe"
    .Cells(1, 10).Value = "statut"
    .Cells(1, 11).Value = "format"
 
 
 End With
 
'on fait les recherchev sur les colonnes de la feuille resultats
 
    PlageRes_Prov = Application.WorksheetFunction.VLookup(PlageRes_Valeur, PlageSoumission_Tout, 2, False)
 
    PlageRes_F = Application.WorksheetFunction.VLookup(PlageRes_Valeur, PlageSoumission_Tout, 3, False)
 
    PlageRes_C = Application.WorksheetFunction.VLookup(PlageRes_Valeur, PlageSoumission_Tout, 4, False)
 
    PlageRes_G = Application.WorksheetFunction.VLookup(PlageRes_Valeur, PlageSoumission_Tout, 5, False)
 
    PlageRes_SG = Application.WorksheetFunction.VLookup(PlageRes_Valeur, PlageSoumission_Tout, 6, False)
 
    PlageRes_Statut = Application.WorksheetFunction.VLookup(PlageRes_Valeur, PlageSoumission_Tout, 7, False)
 
    PlageRes_Format = Application.WorksheetFunction.VLookup(PlageRes_Valeur, PlageCatalogue_Tout, 13, False)
 
 
 
'on fait les rmult pour peupler la feuille Travail
 
    rmult_dico PlageTravail_Code, PlageRes_Code_Cherche, PlageRes_Code_Trouve, PlageTravail_Code_Trouve
 
    rmult_dico PlageTravail_Code, PlageRes_Code_Cherche, PlageRes_Valeur, PlageTravail_LettreP_trouve
 
    rmult_dico PlageTravail_Code, PlageRes_Code_Cherche, PlageRes_Pour100, PlageTravail_LettreSimilar
 
    rmult_dico PlageTravail_Code, PlageRes_Code_Cherche, PlageRes_Prov, PlageTravail_LettreDescr_trouve
 
    rmult_dico PlageTravail_Code, PlageRes_Code_Cherche, PlageRes_F, PlageTravail_LettreF_trouve
 
    rmult_dico PlageTravail_Code, PlageRes_Code_Cherche, PlageRes_C, PlageTravail_LettreC_trouve
 
    rmult_dico PlageTravail_Code, PlageRes_Code_Cherche, PlageRes_G, PlageTravail_LettreG_trouve
 
    rmult_dico PlageTravail_Code, PlageRes_Code_Cherche, PlageRes_SG, PlageTravail_LettreSG_trouve
 
    rmult_dico PlageTravail_Code, PlageRes_Code_Cherche, PlageRes_Statut, PlageTravail_LettreStatut_trouve
 
    rmult_dico PlageTravail_Code, PlageRes_Code_Cherche, PlageRes_Format, PlageTravail_LettreFormat_trouve
 
 
'on détruit les feuilles resultats, soumission_filtrée et Filtre
 
Sheets("resultats").Delete
Sheets("soumission_filtrée").Delete
'Sheets("Filtre").Delete
 
'on détruit la ligne de code bidon du bypass
 
derLigne = Worksheets("Travail").Cells(Worksheets("Travail").Rows.Count, 1).End(xlUp).Row
 
Worksheets("Travail").Rows(derLigne).Delete
 
'on pointe sur la feuille Travail
Worksheets("Travail").Activate
 
 
Application.ScreenUpdating = True
Application.DisplayAlerts = True
 
 
finish = Timer
MsgBox "durée du traitement: " & finish - start & " secondes"
 
Exit Sub
 
errorhandler: MsgBox "cliquer sur le bouton update !!!"
 
End Sub

Étant donné que j'utilise le bouton du formulaire pour lancer la sub et dans la sub, il y a le lancement du userform au lieu que le bouton lance le userform et la sub est imbriqué à l'intérieur. Je tombe avec un problème lorsque l'utilisateur utilise le X pour fermer la fenêtre. Je ne sais pas si je devrais plutôt ouvrir une nouvelle demande ?.


merci encore pour votre aide.

[deedolith]

Hello,

Je n'ai pas tout lu, si tu veux qu'une fonction retourne plusieurs valeurs, il n'y a pas 36 solutions:
1) Utiliser le passage de paramètre par référence (ByRef), adapté lorsque le nombre de paramètres est restreint.

Code :

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

Public Sub Foo(ByRef First As Integer, ByRef Second As String)

2) Retourner un conteneur: Tableau si les types de données sont homogènes, collection ou dictionnaire sinon.

Code :

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

1
2
3
4
5
6
7
Public Function Foo() As Collection
    Dim data As Collection
    Set data = New Collection
    data.Add 25
    data.Add "Something"
    Set Foo = data
End Function

3) Retourner une structure ou une classe

Code :

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

1
2
3
4
5
6
7
8
9
10
11
Type myData
    First As Integer
    Second As String
End Type
 
Public Function Foo() As myData
    Dim data As myData
    data.First = 25
    data.Second = "Something"
    Foo = data
End Function

Concernant ton code:
Une fonction de plus de 400 lignes !!
A mon avis, elle fait beaucoup trop de choses differentes à la fois.
Divise la en plusieurs sous-fonction, ce sera plus lisible, plus compréhensible, plus facile à maintenir.
Quelques liens utiles:
Principe de Responsabilité Unique (ou SRP): https://en.wikipedia.org/wiki/Single...lity_principle
Loi de Demeter: https://en.wikipedia.org/wiki/Law_of_Demeter