ucase stripp accent a un range ou dico au lieu d'une boucle, est-ce possible

**jpvba** · 12/06/2024, 18h52

Bonjour à vous, cher amis du forum

J'ai un code que je voudrais optimiser afin de faire un gain de temps.

Je fais présentement une boucle afin d'appliquer StripAccent UCase CleanTrim à chacune des cellules d'un range

Code :

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

1
2
3
4
5
 For Each y In PlageSoumission_No_manuf
 
        y.Value = StripAccent(UCase(CleanTrim(y.Value)))
 
    Next y

Ma fameuse plage PlageSoumission_No_manuf contient énormément de donné ce qui fais en sorte que ce la prends 40 secondes a effectué cette action.

Il y aurait-il une possibilité d'appliquer ce type de correction sans faire une boucle passant d'une cellule par cellule afin de sauver du temps ?

JE ne sais pas si l'utilisation des dictionnaires pourrait résoudre ce problème mais je ne suis pas à l'aise encore d'utiliser ceux-ci.

merci beaucoup pour votre aide

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
Function StripAccent(thestring As String)
 
    Dim a As String * 1
    Dim B As String * 1
    Dim i As Integer
    Const AccChars = "ŠŽšžŸÀÁÂÃÄÅÇÈÉÊËÌÍÎÏÐÑÒÓÔÕÖÙÚÛÜÝàáâãäåçèéêëìíîïðñòóôõöùúûüýÿ"
    Const RegChars = "SZszYAAAAAACEEEEIIIIDNOOOOOUUUUYaaaaaaceeeeiiiidnooooouuuuyy"
 
    For i = 1 To Len(AccChars)
        a = Mid(AccChars, i, 1)
        B = Mid(RegChars, i, 1)
        thestring = Replace(thestring, a, B)
 
    Next
 
    StripAccent = thestring
 
End Function

Code :

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

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
Function CleanTrim(ByVal s As String, Optional ConvertNonBreakingSpace As Boolean = True) As String
 
    Dim x As Long, CodesToClean As Variant
 
    CodesToClean = Array(0, 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, 127, 129, 141, 143, 144, 157)
 
    If ConvertNonBreakingSpace Then s = Replace(s, Chr(160), " ")
 
    For x = LBound(CodesToClean) To UBound(CodesToClean)
 
    If InStr(s, Chr(CodesToClean(x))) Then s = Replace(s, Chr(CodesToClean(x)), "")
 
    Next
 
    CleanTrim = WorksheetFunction.Trim(s)
 
End Function

**Franc** · 13/06/2024, 01h58

Salut, voici une suggestion avec utilisation d'un tableau en mémoire, c'est toujours plus rapide que de manipuler les cellules dans la feuille.

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
Sub OptimizePlageSoumission_No_manuf()
    Dim PlageSoumission_No_manuf As Range
    Set PlageSoumission_No_manuf = ' Définir votre plage ici
 
    Dim data As Variant
    data = PlageSoumission_No_manuf.Value ' Lire les valeurs dans un tableau
 
    Dim i As Long, j As Long
    For i = LBound(data, 1) To UBound(data, 1)
        For j = LBound(data, 2) To UBound(data, 2)
            data(i, j) = StripAccent(UCase(CleanTrim(data(i, j))))
        Next j
    Next i
 
    PlageSoumission_No_manuf.Value = data ' Écrire les valeurs modifiées dans la plage
End Sub

**jpvba** · 13/06/2024, 22h20

Merci Franc pour ton coup de pouce

Malheureusement j'arrive à la même vitesse que mes autres codes test que j'ai essayés de mon côté

Code avec méthode de Franc

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
Sub test_z_2dico0loop()
 
    Dim i As Long
    Dim j As Long
 
    Dim x As Long
    Dim y As Long
 
    Dim data1 As Variant
    Dim data2 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
 
    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])
 
    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 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 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))
 
 
    data1 = PlageTravail_Code.Value
 
 
    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"))
 
 
    data2 = PlageSoumission_No_manuf.Value
 
 
    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).ClearContents
 
'on nettoie les codes distributeur / manufacturier de la feuille Travail
 
If LastLignUsedInSheet_Column("Travail", LettreCode) > 2 Then
 
    For i = LBound(data1, 1) To UBound(data1, 1)
        For j = LBound(data1, 2) To UBound(data1, 2)
            data1(i, j) = StripAccent(UCase(CleanTrim(data1(i, j))))
        Next j
    Next i
 
    PlageTravail_Code.Value = data1
 
 
Else
 
    Cells(2, LettreCode) = StripAccent(UCase(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_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))
 
End With
 
 
'on nettoie les No_item_manuf de la soumission
 
    For x = LBound(data2, 1) To UBound(data2, 1)
        For y = LBound(data2, 2) To UBound(data2, 2)
            data2(x, y) = StripAccent(UCase(CleanTrim(data2(x, y))))
        Next y
    Next x
 
    PlageSoumission_No_manuf.Value = data2
 
 
'faire rmult_dico afin d'avoir les P_trouvés
 
    rmult_dico PlageTravail_Code, PlageSoumission_No_manuf, PlageSoumission_No_item, PlageTravail_LettreP_trouve
 
'faire rmult_dico afin d'avoir les descriptions trouvés
 
    rmult_dico PlageTravail_Code, PlageSoumission_No_manuf, PlageSoumission_Desc_prov, PlageTravail_LettreDescr_trouve
 
'faire rmult_dico afin d'avoir les F trouvés
 
    rmult_dico PlageTravail_Code, PlageSoumission_No_manuf, PlageSoumission_No_famille, PlageTravail_LettreF_trouve
 
'faire rmult_dico afin d'avoir les C trouvés
 
    rmult_dico PlageTravail_Code, PlageSoumission_No_manuf, PlageSoumission_No_classe, PlageTravail_LettreC_trouve
 
'faire rmult_dico afin d'avoir les G trouvés
 
    rmult_dico PlageTravail_Code, PlageSoumission_No_manuf, PlageSoumission_No_groupe, PlageTravail_LettreG_trouve
 
'faire rmult_dico afin d'avoir les SG trouvés
 
    rmult_dico PlageTravail_Code, PlageSoumission_No_manuf, PlageSoumission_No_ss_groupe, PlageTravail_LettreSG_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

méthode 2 loops

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
Sub test_0dico2loop()
 
    Dim x As Variant
    Dim y 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
 
    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])
 
    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 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 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))
 
 
    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"))
 
 
    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).ClearContents
 
'on loop afin de nettoyer code distributeur dans l'onglet Travail
 
 
    For Each x In PlageTravail_Code
 
        x.Value = StripAccent(UCase(CleanTrim(x.Value)))
 
    Next x
 
 
 
'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))
 
End With
 
'_______________________________________________________________________________
 
'on nettoie les code manufacturier dans les soumissions
 
    For Each y In PlageSoumission_No_manuf
 
        y.Value = StripAccent(UCase(CleanTrim(y.Value)))
 
    Next y
 
 
 
'_______________________________________________________________________________
 
'faire rmult_dico afin d'avoir les P_trouvés
 
    rmult_dico PlageTravail_Code, PlageSoumission_No_manuf, PlageSoumission_No_item, PlageTravail_LettreP_trouve
 
'faire rmult_dico afin d'avoir les descriptions trouvés
 
    rmult_dico PlageTravail_Code, PlageSoumission_No_manuf, PlageSoumission_Desc_prov, PlageTravail_LettreDescr_trouve
 
'faire rmult_dico afin d'avoir les F trouvés
 
    rmult_dico PlageTravail_Code, PlageSoumission_No_manuf, PlageSoumission_No_famille, PlageTravail_LettreF_trouve
 
'faire rmult_dico afin d'avoir les C trouvés
 
    rmult_dico PlageTravail_Code, PlageSoumission_No_manuf, PlageSoumission_No_classe, PlageTravail_LettreC_trouve
 
'faire rmult_dico afin d'avoir les G trouvés
 
    rmult_dico PlageTravail_Code, PlageSoumission_No_manuf, PlageSoumission_No_groupe, PlageTravail_LettreG_trouve
 
'faire rmult_dico afin d'avoir les SG trouvés
 
    rmult_dico PlageTravail_Code, PlageSoumission_No_manuf, PlageSoumission_No_ss_groupe, PlageTravail_LettreSG_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

Méthode 1 dictionnaire et 1 loop

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
Sub test_1dico1loop()
 
    Dim i As Long
 
    Dim y As Variant
 
    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
 
    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])
 
    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 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 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 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"))
 
 
    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).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é = StripAccent(UCase(CleanTrim(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) = StripAccent(UCase(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_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))
 
End With
 
'_______________________________________________________________________________
 
'on nettoie les code manufacturier dans les soumissions
 
    For Each y In PlageSoumission_No_manuf
 
        y.Value = StripAccent(UCase(CleanTrim(y.Value)))
 
    Next y
 
 
 
'_______________________________________________________________________________
 
'faire rmult_dico afin d'avoir les P_trouvés
 
    rmult_dico PlageTravail_Code, PlageSoumission_No_manuf, PlageSoumission_No_item, PlageTravail_LettreP_trouve
 
'faire rmult_dico afin d'avoir les descriptions trouvés
 
    rmult_dico PlageTravail_Code, PlageSoumission_No_manuf, PlageSoumission_Desc_prov, PlageTravail_LettreDescr_trouve
 
'faire rmult_dico afin d'avoir les F trouvés
 
    rmult_dico PlageTravail_Code, PlageSoumission_No_manuf, PlageSoumission_No_famille, PlageTravail_LettreF_trouve
 
'faire rmult_dico afin d'avoir les C trouvés
 
    rmult_dico PlageTravail_Code, PlageSoumission_No_manuf, PlageSoumission_No_classe, PlageTravail_LettreC_trouve
 
'faire rmult_dico afin d'avoir les G trouvés
 
    rmult_dico PlageTravail_Code, PlageSoumission_No_manuf, PlageSoumission_No_groupe, PlageTravail_LettreG_trouve
 
'faire rmult_dico afin d'avoir les SG trouvés
 
    rmult_dico PlageTravail_Code, PlageSoumission_No_manuf, PlageSoumission_No_ss_groupe, PlageTravail_LettreSG_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

Méthode 2 dictionnaires

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
Sub test_2dico0loop()
 
    Dim i As Long
    Dim j As Long
 
    Dim dico As Object
    Dim dico2 As Object
 
    Dim clé As String
    Dim clé2 As String
 
    Dim TblBD1 As Variant
    Dim TblBD2 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
 
    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])
 
    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 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 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 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 dico2 = CreateObject("Scripting.Dictionary")
    TblBD2 = .Range("a2: a" & 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).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é = StripAccent(UCase(CleanTrim(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) = StripAccent(UCase(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_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))
 
End With
 
'_______________________________________________________________________________
 
'on transpose le dictionnaire des soumission tout en le nettoyant
 
 
    For j = 1 To UBound(TblBD2)
 
 
                clé2 = StripAccent(UCase(CleanTrim(TblBD2(j, 1))))
                dico2(clé2) = TblBD2(j, 1)
 
    Next j
 
Sheets("soumission").Range("a2").Resize(dico2.Count) = Application.Transpose(dico2.keys)
 
 
'_______________________________________________________________________________
 
'faire rmult_dico afin d'avoir les P_trouvés
 
    rmult_dico PlageTravail_Code, PlageSoumission_No_manuf, PlageSoumission_No_item, PlageTravail_LettreP_trouve
 
'faire rmult_dico afin d'avoir les descriptions trouvés
 
    rmult_dico PlageTravail_Code, PlageSoumission_No_manuf, PlageSoumission_Desc_prov, PlageTravail_LettreDescr_trouve
 
'faire rmult_dico afin d'avoir les F trouvés
 
    rmult_dico PlageTravail_Code, PlageSoumission_No_manuf, PlageSoumission_No_famille, PlageTravail_LettreF_trouve
 
'faire rmult_dico afin d'avoir les C trouvés
 
    rmult_dico PlageTravail_Code, PlageSoumission_No_manuf, PlageSoumission_No_classe, PlageTravail_LettreC_trouve
 
'faire rmult_dico afin d'avoir les G trouvés
 
    rmult_dico PlageTravail_Code, PlageSoumission_No_manuf, PlageSoumission_No_groupe, PlageTravail_LettreG_trouve
 
'faire rmult_dico afin d'avoir les SG trouvés
 
    rmult_dico PlageTravail_Code, PlageSoumission_No_manuf, PlageSoumission_No_ss_groupe, PlageTravail_LettreSG_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 les données que j'ai a effectuer la tâche, j'arrive à environ 60 secondes, peut importe les méthodes. Le fait de nettoyer les données prends environ 48 des 60 secondes en moyennes

Invité · 13/06/2024, 22h34

Essaie ce code que j'ai posté ce matin et que j'ai retiré après car ne contient pas tous les caractères accentués qui figurent dans votre fonction, mais ca peut vous donner des idées

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
Function CleanAcc(ByVal aTxt As String) As String
Dim TabSub() As Byte
  Dim AccTxt As String
  Dim bt() As Byte
  Dim bOut() As Byte
  Dim i As Long, zPos As Long, n As Integer
  If Len(aTxt) = 0 Then Exit Function
  AccTxt = "AAAAAAÆCEEEEIIIIÐNOOOOO×ØUUUUYÞßAAAAAAÆCEEEEIIIIÐNOOOOO÷ØUUUUYÞY"
  TabSub = StrConv(AccTxt, vbFromUnicode)
  bt = StrConv(aTxt, vbFromUnicode)
  ReDim bOut(UBound(bt))
  zPos = 0
  For i = 0 To UBound(bt)
     n = bt(i)
     Select Case n
      Case Is <= 32: n = 0
      Case Is >= 192: n = TabSub(n - 192)
      Case 127, 129, 141, 143, 144, 157: n = 0
     End Select
     If n <> 0 Then
       bOut(zPos) = n
       zPos = zPos + 1
     End If
  Next
  If i <> zPos Then
     ReDim Preserve bOut(zPos)
  End If
  CleanAcc = StrConv(bOut, vbUnicode)
End Function
 
 
Sub OptimizePlageSoumission_No_manuf()
 
    Dim PlageSoumission_No_manuf As Range
    Set PlageSoumission_No_manuf =  ' range à definir
 
    Dim data As Variant
    data = PlageSoumission_No_manuf.Value ' Lire les valeurs dans un tableau
 
    Dim i As Long, j As Long
    For i = LBound(data, 1) To UBound(data, 1)
        For j = LBound(data, 2) To UBound(data, 2)
            data(i, j) = CleanAcc(data(i, j))
        Next j
    Next i
 
    PlageSoumission_No_manuf.Value = data ' Écrire les valeurs modifiées dans la plage
 
End Sub

**jpvba** · 13/06/2024, 23h06

Merci Volid,

Je n'ai malheureusement aucun gain de vitesse d'autant plus cela enlève les espaces dont j'ai de besoin

Invité · 13/06/2024, 23h28

d'autant plus cela enlève les espaces dont j'ai de besoin

Pour laisser les espaces changer la condition Case Is <= 32: n = 0 vers Case Is < 32: n = 0 j'ai oublier de la remettre pendant les tests.

Je n'ai malheureusement aucun gain de vitesse

Tu peux donner le nombre des mots dans votre classeur afin que je puisse comparer

**fraflt69** · 14/06/2024, 08h47

Bonjour jpvba, volid

J'avais un peu réfléchi au sujet, je trouve l'approche de volid dans l'esprit que j'y aurais apporté, travailler en mémoire et remplacer les nombreuses boucles par cellule derrière les appels imbriqués de = StripAccent(UCase(CleanTrim( et les commandes Replace, par une simple boucle incluant un switch portant sur les codes de caractères . Je ne vois pas ce que l'on peut rajouter pour accélérer le traitement. Je vais essayer de comprendre l'exhaustivité des caractères accentués de la constante AccTxt

Je vais suivre le sujet de l'optimisation.

**Franc** · 14/06/2024, 12h38

Salut, une autre suggestion:

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
Sub MacroTest()
 
    Dim start As Single, finish As Single
    start = Timer
 
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False
 
    Dim wsTravail As Worksheet, wsSoumission As Worksheet
    Set wsTravail = Worksheets("Travail")
    Set wsSoumission = Worksheets("soumission")
 
    Dim LettreCode As String, LettreP_trouve As String, LettreDescr_trouve As String
    Dim LettreF_trouve As String, LettreC_trouve As String, LettreG_trouve As String, LettreSG_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])
 
    Dim PlageTravail_Code As Range, PlageSoumission_No_manuf As Range
    Set PlageTravail_Code = wsTravail.Range(LettreCode & "2", LettreCode & LastLignUsedInSheet_Column("Travail", LettreCode))
    Set PlageSoumission_No_manuf = wsSoumission.Range("A2", "A" & LastLignUsedInSheet_Column("soumission", "A"))
 
    Dim dataTravail As Variant, dataSoumission As Variant
    dataTravail = PlageTravail_Code.Value
    dataSoumission = PlageSoumission_No_manuf.Value
 
    Dim dico As Object
    Set dico = CreateObject("Scripting.Dictionary")
 
    ' Nettoyer les données et remplir le dictionnaire
    Dim i As Long
    For i = 1 To UBound(dataTravail, 1)
        dataTravail(i, 1) = StripAccent(UCase(CleanTrim(dataTravail(i, 1))))
        If Not dico.exists(dataTravail(i, 1)) Then
            dico(dataTravail(i, 1)) = i
        End If
    Next i
    PlageTravail_Code.Value = dataTravail
 
    Dim y As Long
    For y = 1 To UBound(dataSoumission, 1)
        dataSoumission(y, 1) = StripAccent(UCase(CleanTrim(dataSoumission(y, 1))))
    Next y
    PlageSoumission_No_manuf.Value = dataSoumission
 
    ' Initialiser les plages de destination
    Dim PlageTravail_LettreP_trouve As Range, PlageTravail_LettreDescr_trouve As Range
    Dim PlageTravail_LettreF_trouve As Range, PlageTravail_LettreC_trouve As Range
    Dim PlageTravail_LettreG_trouve As Range, PlageTravail_LettreSG_trouve As Range
    Set PlageTravail_LettreP_trouve = wsTravail.Range(LettreP_trouve & "2", LettreP_trouve & UBound(dataTravail, 1) + 1)
    Set PlageTravail_LettreDescr_trouve = wsTravail.Range(LettreDescr_trouve & "2", LettreDescr_trouve & UBound(dataTravail, 1) + 1)
    Set PlageTravail_LettreF_trouve = wsTravail.Range(LettreF_trouve & "2", LettreF_trouve & UBound(dataTravail, 1) + 1)
    Set PlageTravail_LettreC_trouve = wsTravail.Range(LettreC_trouve & "2", LettreC_trouve & UBound(dataTravail, 1) + 1)
    Set PlageTravail_LettreG_trouve = wsTravail.Range(LettreG_trouve & "2", LettreG_trouve & UBound(dataTravail, 1) + 1)
    Set PlageTravail_LettreSG_trouve = wsTravail.Range(LettreSG_trouve & "2", LettreSG_trouve & UBound(dataTravail, 1) + 1)
 
    ' Appel unique à la fonction rmult_dico pour chaque colonne cible
    rmult_dico dico, PlageSoumission_No_manuf, PlageSoumission_No_item, PlageTravail_LettreP_trouve
    rmult_dico dico, PlageSoumission_No_manuf, PlageSoumission_Desc_prov, PlageTravail_LettreDescr_trouve
    rmult_dico dico, PlageSoumission_No_manuf, PlageSoumission_No_famille, PlageTravail_LettreF_trouve
    rmult_dico dico, PlageSoumission_No_manuf, PlageSoumission_No_classe, PlageTravail_LettreC_trouve
    rmult_dico dico, PlageSoumission_No_manuf, PlageSoumission_No_groupe, PlageTravail_LettreG_trouve
    rmult_dico dico, PlageSoumission_No_manuf, PlageSoumission_No_ss_groupe, PlageTravail_LettreSG_trouve
 
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
 
    finish = Timer
    MsgBox "Durée du traitement: " & finish - start & " secondes"
 
End Sub

**jpvba** · 14/06/2024, 16h47

Bonjour à vous,

Tu peux donner le nombre des mots dans votre classeur afin que je puisse comparer

Je ne comprends pas le sens de la question mais dans ma feuille "soumission" présentement dans mes test j'ai 403990 cellules de long par 7 cellule de large. Le nettoyage à donc 403990 cellules auquel on enlève les double espaces, accent, mettre en majuscule.

Pour le code proposé par Franc

Malheureusement, je bute à une incompatibilité de type pour les rmult_dico

Je laisse le code de celui-ci

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

code proposé par franc avec l'ajout des Dim et set de certaines plages oubliés

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
Sub zzzMacroTest()
 
    Dim start As Single, finish As Single
    start = Timer
 
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False
 
    Dim wsTravail As Worksheet, wsSoumission As Worksheet
    Set wsTravail = Worksheets("Travail")
    Set wsSoumission = Worksheets("soumission")
 
    Dim LettreCode As String, LettreP_trouve As String, LettreDescr_trouve As String
    Dim LettreF_trouve As String, LettreC_trouve As String, LettreG_trouve As String, LettreSG_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])
 
    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 PlageTravail_Code As Range
    Set PlageTravail_Code = wsTravail.Range(LettreCode & "2", LettreCode & LastLignUsedInSheet_Column("Travail", LettreCode))
    Set PlageSoumission_No_manuf = wsSoumission.Range("A2", "A" & LastLignUsedInSheet_Column("soumission", "A"))
 
    Dim dataTravail As Variant, dataSoumission As Variant
    dataTravail = PlageTravail_Code.Value
    dataSoumission = PlageSoumission_No_manuf.Value
 
    Dim dico As Object
    Set dico = CreateObject("Scripting.Dictionary")
 
    ' Nettoyer les données et remplir le dictionnaire
    Dim i As Long
    For i = 1 To UBound(dataTravail, 1)
        dataTravail(i, 1) = StripAccent(UCase(CleanTrim(dataTravail(i, 1))))
        If Not dico.exists(dataTravail(i, 1)) Then
            dico(dataTravail(i, 1)) = i
        End If
    Next i
    PlageTravail_Code.Value = dataTravail
 
    Dim y As Long
    For y = 1 To UBound(dataSoumission, 1)
        dataSoumission(y, 1) = StripAccent(UCase(CleanTrim(dataSoumission(y, 1))))
    Next y
    PlageSoumission_No_manuf.Value = dataSoumission
 
    ' Initialiser les plages de destination
    Dim PlageTravail_LettreP_trouve As Range, PlageTravail_LettreDescr_trouve As Range
    Dim PlageTravail_LettreF_trouve As Range, PlageTravail_LettreC_trouve As Range
    Dim PlageTravail_LettreG_trouve As Range, PlageTravail_LettreSG_trouve As Range
    Set PlageTravail_LettreP_trouve = wsTravail.Range(LettreP_trouve & "2", LettreP_trouve & UBound(dataTravail, 1) + 1)
    Set PlageTravail_LettreDescr_trouve = wsTravail.Range(LettreDescr_trouve & "2", LettreDescr_trouve & UBound(dataTravail, 1) + 1)
    Set PlageTravail_LettreF_trouve = wsTravail.Range(LettreF_trouve & "2", LettreF_trouve & UBound(dataTravail, 1) + 1)
    Set PlageTravail_LettreC_trouve = wsTravail.Range(LettreC_trouve & "2", LettreC_trouve & UBound(dataTravail, 1) + 1)
    Set PlageTravail_LettreG_trouve = wsTravail.Range(LettreG_trouve & "2", LettreG_trouve & UBound(dataTravail, 1) + 1)
    Set PlageTravail_LettreSG_trouve = wsTravail.Range(LettreSG_trouve & "2", LettreSG_trouve & UBound(dataTravail, 1) + 1)
 
 
    'initialiser les plages soumission
    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"))
 
 
 
    End With
 
 
    ' Appel unique à la fonction rmult_dico pour chaque colonne cible
    rmult_dico dico, PlageSoumission_No_manuf, PlageSoumission_No_item, PlageTravail_LettreP_trouve
    rmult_dico dico, PlageSoumission_No_manuf, PlageSoumission_Desc_prov, PlageTravail_LettreDescr_trouve
    rmult_dico dico, PlageSoumission_No_manuf, PlageSoumission_No_famille, PlageTravail_LettreF_trouve
    rmult_dico dico, PlageSoumission_No_manuf, PlageSoumission_No_classe, PlageTravail_LettreC_trouve
    rmult_dico dico, PlageSoumission_No_manuf, PlageSoumission_No_groupe, PlageTravail_LettreG_trouve
    rmult_dico dico, PlageSoumission_No_manuf, PlageSoumission_No_ss_groupe, PlageTravail_LettreSG_trouve
 
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
 
    finish = Timer
    MsgBox "Durée du traitement: " & finish - start & " secondes"
 
End Sub

**Nain porte koi** · 14/06/2024, 16h49

Hello

Envoyé par jpvba

J'ai un code que je voudrais optimiser afin de faire un gain de temps.

est-ce que votre code contient

Code :

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

1
2
3
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False

ça accélère grandement les choses

**jpvba** · 14/06/2024, 17h01

Salut Nain porte koi

j'avais le screenupdating mais pas les 2 autres.

J'ai faites les test en ajoutant les 2 que tu mentionne et je n'ai pas plus de gain. Étant donné que l'on enlève la mise à jour de l'écran, je crois que les 2 autres n'ont plus d'impact étant donné qu'il touche l'affichage, ce qui expliquerais au temps identique.

merci pour la réponse ça aurais pu être une voie.

Invité · 15/06/2024, 11h17

J'ai fait des tests sur CleanAcc et ajouté des petites optimisations, le test sur un boucle de 400000 itérations prend environ 19 seconds pour nettoyer les accents c'est presque le même temps pour la fonction windows FoldString qui sépare les lettres de leur accents ,l'ancien code StripAccent (UCase(CleanTrim( ))) prend environ 50 second pour seulement 40000 boucles.

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
 Function CleanAcc(ByVal aTxt As String) As String
  Static TabSub() As Byte
  Static initialized As Boolean
  Dim bt() As Byte
  Dim bOut() As Byte
  Dim i As Long, zPos As Long, n As Long
  If Len(aTxt) = 0 Then Exit Function
 
  If Not initialized Then
    initialized = True
    Dim AccTxt As String
    AccTxt = "AAAAAAÆCEEEEIIIIÐNOOOOO×ØUUUUYÞßAAAAAAÆCEEEEIIIIÐNOOOOO÷ØUUUUYÞY"
    TabSub = StrConv(AccTxt, vbFromUnicode)
  End If
  bt = aTxt
  ReDim bOut(UBound(bt))
  zPos = 0
  For i = 0 To UBound(bt) Step 2
     n = bt(i) Or CLng(bt(i + 1)) * 256
     Select Case n
      Case Is < 32: n = 0
      Case Is < 97:
      Case Is <= 122: n = n - 32 'maj
      Case Is >= 192: n = TabSub(n - 192)
      Case 127, 129, 141, 143, 144, 157: n = 0
     End Select
     If n <> 0 Then
       bOut(zPos) = n
       zPos = zPos + 1
     End If
  Next
  If i <> zPos Then
     ReDim Preserve bOut(zPos)
  End If
  CleanAcc = StrConv(bOut, vbUnicode)
End Function
 
Private Sub CleanAccTest()
    Dim s As String
    Dim TabSub() As Byte
    s = "ÀÁÂÃÄÅÇÈÉÊËÌÍÎÏÒÓÔÕÖ"
    Dim i As Long
    k = Timer
    For i = 0 To 400000
      CleanAcc s
      ' StripAccent (UCase(CleanTrim(s)))
       If i Mod 5000 = 0 Then
         DoEvents
       End If
    Next i
    MsgBox Timer - k
End Sub

**jpvba** · 27/06/2024, 20h40

Bonjour Void,

Je suis entrain de tester votre code et j'ai un erreur d'exécution 9 : L'indice n'appartient pas à la sélection me pointant sur

Code :

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

n = TabSub(n - 192)

dans

Code :

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

1
2
3
4
5
6
7
8
9
For i = 0 To UBound(bt) Step 2
     n = bt(i) Or CLng(bt(i + 1)) * 256
     Select Case n
      Case Is < 32: n = 0
      Case Is < 97:
      Case Is <= 122: n = n - 32 'maj
      Case Is >= 192: n = TabSub(n - 192)
      Case 127, 129, 141, 143, 144, 157: n = 0
     End Select

j'essaie de la résoudre et ne la comprends malheureusement pas

Invité · 27/06/2024, 23h23

Il semble que c'est problème avec un caractère large dont la valeur dépasse 255 alors il provoque l'erreur, la mauvais nouvelle est que StrConv ne supporte pas l'unicode et pour pouvoir composer les caractères larges d'une manière un peu optimisée on devrait agir directement dans un tableau d'octets c'est plus rapide que de faire une concaténation avec ChrW

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
   Function CleanAcc(ByVal aTxt As String) As String
  Static TabSub() As Byte
  Static initialized As Boolean
  Dim bt() As Byte
  Dim uIsSpace As Long
  Dim i As Long, zPos As Long, n As Long, u As Long
  If Len(aTxt) = 0 Then Exit Function
 
  If Not initialized Then
    initialized = True
    Dim AccTxt As String
    AccTxt = "AAAAAAÆCEEEEIIIIÐNOOOOO×ØUUUUYÞßAAAAAAÆCEEEEIIIIÐNOOOOO÷ØUUUUYÞY"
    TabSub = StrConv(AccTxt, vbFromUnicode)
  End If
  bt = Trim(aTxt)
  zPos = 0
  For i = 0 To UBound(bt) Step 2
     u = bt(i + 1)
     n = bt(i)
     If u = 0 Then
        Select Case n
         Case Is < 32: n = 0
         Case 32:
              If uIsSpace = i Then n = 0
              uIsSpace = i + 2
         Case Is < 97:
         Case Is <= 122: n = n - 32 'maj
         Case Is >= 192: n = TabSub(n - 192)
         Case 127, 129, 141, 143, 144, 157: n = 0
        End Select
     Else ' unicode
        Select Case n Or CLng(u) * 256
         Case 352, 353: n = 83: u = 0 'Š š
         Case 381, 382: n = 90: u = 0 'Ž ž
         Case 376: n = 89: u = 0  'Ÿ
        End Select
     End If
    If n <> 0 Then
       bt(zPos) = n
       bt(zPos + 1) = u
       zPos = zPos + 2
     End If
  Next
  If i <> zPos Then
     ReDim Preserve bt(0 To zPos - 1)
  End If
  CleanAcc = bt
End Function

**jpvba** · 27/06/2024, 23h47

Re-Salut Volid

Je sauve environ 10 seconde mais les espaces de trop ne sont pas éliminés avec votre code.

Il manque seulement ça et je crois que c'Est réglé

Invité · 28/06/2024, 11h54

ajouter Trim sur cette ligne bt = Trim(aTxt) cette fonction native est plus rapide que n'importe quelle optimisation envisageable sur le code...en tous cas le temps d"exécution reste le même avec ou sans elle

**jpvba** · 28/06/2024, 16h29

La fonction Trim enlève seulement les espaces superflus au début et à la fin. Elle ne permet pas d'enlever les doubles ou triples espaces entre les mots, ce que j'ai besoins.

Invité · 28/06/2024, 19h50

Regarder le message #14 j'ai corriger directement dans ce poste l'ancien code contient une erreur dans le redimensionnement du tableau de la sortie en cas des caractères ont été supprimés

**jpvba** · 28/06/2024, 21h27

Merci à vous tous

Merci à Volid, c'est parfait !!!!

Invité · 28/06/2024, 23h09

Les dernières corrections la première concerne le test If n <> 0 Then incorrect qui ne contient que le poids faible alors qu'il est possible qu'un caractère ait une valeur nulle pour ce poids, le test actuellement se fait sur -1 qui indique que le caractère n'est pas valide et ne sera pas enregistrer, la seconde correction concerne la suppression les séquences des espaces avec d'autres caractères invalides.

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
Function CleanAcc(ByVal aTxt As String) As String
  Static TabSub() As Byte
  Static initialized As Boolean
  Dim bt() As Byte
  Dim uIsSpace As Long
  Dim i As Long, zPos As Long, n As Long, u As Long
  If Len(aTxt) = 0 Then Exit Function
 
  If Not initialized Then
    initialized = True
    Dim AccTxt As String
    AccTxt = "AAAAAAÆCEEEEIIIIÐNOOOOO×ØUUUUYÞßAAAAAAÆCEEEEIIIIÐNOOOOO÷ØUUUUYÞY"
    TabSub = StrConv(AccTxt, vbFromUnicode)
  End If
  bt = Trim(aTxt)
  zPos = 0
  For i = 0 To UBound(bt) Step 2
     u = bt(i + 1)
     n = bt(i)
     If u = 0 Then
        Select Case n
         Case Is < 32: n = -1: uIsSpace = uIsSpace + 2
         Case 32:
              If uIsSpace = i Then n = -1
              uIsSpace = i + 2
         Case Is < 97:
         Case Is <= 122: n = n - 32 'maj
         Case Is >= 192: n = TabSub(n - 192)
         Case 127, 129, 141, 143, 144, 157: n = -1: uIsSpace = uIsSpace + 2
        End Select
     Else ' unicode
        Select Case n Or CLng(u) * 256
         Case 352, 353: n = 83: u = 0 'Š š
         Case 381, 382: n = 90: u = 0 'Ž ž
         Case 376: n = 89: u = 0  'Ÿ
        End Select
     End If
    If n <> -1 Then
       bt(zPos) = n
       bt(zPos + 1) = u
       zPos = zPos + 2
     End If
  Next
  If i <> zPos Then
     ReDim Preserve bt(0 To zPos - 1)
  End If
  CleanAcc = bt
End Function

ucase stripp accent a un range ou dico au lieu d'une boucle, est-ce possible [XL-365]

Macros et VBA Excel

Discussions similaires

Partager

Partager