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

**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

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

Macros et VBA Excel

Vue hybride

Discussions similaires

Partager

Partager