Discussion :

[jpvba]

Bonjour à vous,

J'ai actuellement un code qui permet de remplacer certaines données selon des séparateurs et on enlève les accents, majuscules, caractères spéciaux et autre caractères qui ne sont pas compatible avec mon besoins. Le code va cherché dans un onglet nommé data les éléments ayant 1 dans la colonne C et remplace l'éléments de la colonne A par celui de la conne B de la même ligne

Le code actuel est très lent à exécuté et je suis à la recherche de solutions afin d'optimiser celui-ci mais ce que j'ai fait présentement le alenti. Je n'ai pas d'expérience avec les dictionnaires et je ne sais pas si ce serais une solution afin de gagné du temps d'exécution.

Code actuel :

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
Sub test2_preparerCelluleSelectedCell()
 
On Error GoTo errorhandler:
 
    Dim sourceCell As Variant
    Dim cell As Variant
    Dim ReplaceValue As Variant
    Dim ReplaceValuewith As Variant
 
    Dim start As Single
    Dim finish As Single
 
    Application.ScreenUpdating = False
 
    start = Timer
 
    For Each sourceCell In Selection
 
        nettoyerseul
 
        'Do a loop in all of data rows to get the value to replace and with what to replace it
 
        For Each cell In Worksheets("data").Range("A1:A" & LastLignUsedInSheet("data"))
            ReplaceValue = cell.Value
            If Len(Trim(ReplaceValue)) > 0 Then
                If cell.Offset(0, 2).Value = 1 Then
                'Get values to replace with
                    ReplaceValuewith = cell.Offset(0, 1).Value
                    'do the replacement
                    sourceCell.Value = findAndReplaceBettewSpacesOrMarkers(sourceCell.Value, ReplaceValue, ReplaceValuewith)
                End If
 
            End If
        Next
    Next
 
    finish = Timer
 
MsgBox "durée du traitement: " & finish - start & " secondes"
 
Exit Sub
 
errorhandler: MsgBox "cliquer sur le bouton update !!!"
 
End Sub

Dont les fonctions suivantes sont utilisé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
Public Function findAndReplaceBettewSpacesOrMarker(originalValue, ReplaceValue, ReplaceValuewith, marker) As String
 
    Dim leftOrRightReplaceValue As String
 
    'Replace in middle of string
 
    originalValue = Replace(UCase(originalValue), " " & ReplaceValue & marker, " " & ReplaceValuewith & marker)
    originalValue = Replace(UCase(originalValue), marker & ReplaceValue & " ", marker & ReplaceValuewith & " ")
    originalValue = Replace(UCase(originalValue), marker & ReplaceValue & marker, marker & ReplaceValuewith & marker)
 
    'replace at the begining of the string
 
    leftOrRightReplaceValue = ReplaceValue & marker
 
    If Left(UCase(originalValue), Len(leftOrRightReplaceValue)) = leftOrRightReplaceValue Then
       originalValue = ReplaceValuewith & marker & Right(UCase(originalValue), (Len(UCase(originalValue)) - Len(leftOrRightReplaceValue)))
    End If
 
    'replace at the end of the string
 
    leftOrRightReplaceValue = marker & ReplaceValue
 
    If Right(UCase(originalValue), Len(leftOrRightReplaceValue)) = leftOrRightReplaceValue Then
       originalValue = Left(UCase(originalValue), (Len(UCase(originalValue)) - Len(leftOrRightReplaceValue))) & marker & ReplaceValuewith
    End If
 
    findAndReplaceBettewSpacesOrMarker = originalValue
 
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
Public Function findAndReplaceBettewSpacesOrMarkers(originalValue, ReplaceValue, ReplaceValuewith) As String
 
    originalValue = findAndReplaceBettewSpacesOrMarker(originalValue, ReplaceValue, ReplaceValuewith, " ")
    originalValue = findAndReplaceBettewSpacesOrMarker(originalValue, ReplaceValue, ReplaceValuewith, ",")
    originalValue = findAndReplaceBettewSpacesOrMarker(originalValue, ReplaceValue, ReplaceValuewith, "/")
 
 
    originalValue = findAndReplaceBettewSpacesOrMarker(originalValue, ReplaceValue, ReplaceValuewith, "\")
    originalValue = findAndReplaceBettewSpacesOrMarker(originalValue, ReplaceValue, ReplaceValuewith, "(")
    originalValue = findAndReplaceBettewSpacesOrMarker(originalValue, ReplaceValue, ReplaceValuewith, ")")
    originalValue = findAndReplaceBettewSpacesOrMarker(originalValue, ReplaceValue, ReplaceValuewith, ";")
    originalValue = findAndReplaceBettewSpacesOrMarker(originalValue, ReplaceValue, ReplaceValuewith, "'")
    originalValue = findAndReplaceBettewSpacesOrMarker(originalValue, ReplaceValue, ReplaceValuewith, Chr(34))
 
    findAndReplaceBettewSpacesOrMarkers = originalValue
 
End Function

J'ai pensée d'éviter de valider la colonne C et d'épuré les données afin que la boucle sois plus courte. Malheureusement cette solution est 10 fois plus lentes. JE réutilise les mêmes fonctions que le code originale

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
Sub test1_preparerCelluleSelectedCell()
 
'On Error GoTo errorhandler:
 
    Dim sourceCell As Variant
    Dim cell As Variant
    Dim ReplaceValue As Variant
    Dim ReplaceValuewith As Variant
 
    Dim start As Single
    Dim finish As Single
 
 
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
 
    start = Timer
 
    'si la feuille filtre_data existe, on la supprime
 
    If sheetExists("filtre_data") Then Sheets("filtre_data").Delete
 
 
    'creation de la feuille data pour validation
 
    Sheets.Add.Name = "filtre_data"
 
    'on fait des titres afin de facilité le filtre future
    Sheets("filtre_data").Range("A1") = "ancien"
    Sheets("filtre_data").Range("b1") = "nouveau"
    Sheets("filtre_data").Range("c1") = "si 1"
 
 
 
    'on copie les cellules de la colonne A, B et C de data dans la seconde ligne de filtre_data
 
     With Sheets("data")
 
 
    .Range("A1", "A" & LastLignUsedInSheet("data")).Copy Sheets("filtre_data").Range("a2")
    .Range("b1", "b" & LastLignUsedInSheet("data")).Copy Sheets("filtre_data").Range("b2")
    .Range("c1", "c" & LastLignUsedInSheet("data")).Copy Sheets("filtre_data").Range("c2")
 
 
     End With
 
 
    'Appliquer le filtre sur la colonne "si 1" pour les valeurs vides afin de les supprimer
 
     With Sheets("filtre_data")
 
     .Range("A1:C" & LastLignUsedInSheet("filtre_data")).AutoFilter Field:=3, Criteria1:=""
 
 
    'supprimer les lignes qui ne correspondent pas au filtre
 
     .Range("A2:C" & LastLignUsedInSheet("filtre_data")).SpecialCells(xlCellTypeVisible).EntireRow.Delete
 
 
    ' Désactiver le filtre
 
    .AutoFilterMode = False
 
 
     End With
 
 
     'on pointe sur la feuille Ravail afin de ne pas perdre la selction
 
     Sheets("Travail").Select
 
 
 
 
    'on défini les variables
 
    ReplaceValue = Sheets("filtre_data").Range("A2:a" & LastLignUsedInSheet("filtre_data"))
 
    ReplaceValuewith = Sheets("filtre_data").Range("b2:b" & LastLignUsedInSheet("filtre_data"))
 
 
     'on fait la boucle
 
     For Each sourceCell In Selection
 
        nettoyerseul
 
        'Do a loop in all of data rows to get the value to replace and with what to replace it
 
        For Each cell In Worksheets("filtre_data").Range("A2:A" & LastLignUsedInSheet("data"))
 
            'Get values to replace with
 
            ReplaceValue = cell.Value
            ReplaceValuewith = cell.Offset(0, 1).Value
 
            'do the replacement
            sourceCell.Value = findAndReplaceBettewSpacesOrMarkers(sourceCell.Value, ReplaceValue, ReplaceValuewith)
 
 
        Next
 
     Next
 
 'si la feuille filtre_data existe, on la supprime
 
    If sheetExists("filtre_data") Then Sheets("filtre_data").Delete
 
 
finish = Timer
 
MsgBox "durée du traitement: " & finish - start & " secondes"
 
 
Exit Sub
 
Application.ScreenUpdating = False
Application.DisplayAlerts = False
 
 
errorhandler: MsgBox "cliquer sur le bouton update !!!"
 
'si la feuille filtre_data existe, on la supprime
 
If sheetExists("filtre_data") Then Sheets("filtre_data").Delete
 
End Sub

Vos suggestions et aides sont les bienvenues