optimisation de Replace selon des séparateurs

**jpvba** · 26/02/2025, 22h04

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

**Alex020181** · 27/02/2025, 05h00

Bonjour,

Je te conseille très très fortement d'utiliser les tableaux mémoires et les dictionnaires pour faire ces remplacements.

Pense aussi que chaque fois que tu lis ou écris dans ta feuille tu prends du temps. Hors ton code fais beaucoup de contrôles, lecture et écriture sur tes feuilles. Tu perds énormément de temps là-dessus.

Code VBA :

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

1
2
3
4
5
For Each sourceCell In Selection

....

Next

Et à l'intérieur même de cette boucle tu en utilises une autre

Code VBA :

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

1
2
3
4
5
For Each cell In Worksheets("data").Range("A1:A" & LastLignUsedInSheet("data"))

....

Next

Chacune de tes cellules de Data:A1:Ax est lue et relue autant de fois que tu as de lignes dans ta première boucle.

C'est la cata chronophage si tu me passes l'expression. D'autant qu'en plus à l'intérieur de ces boucles tu fais encore des accès aux cellules (offset par exemple).

Pour info aussi sache qu'à chaque fois que tu écris dans une cellule Excel vérifie si cette mise à jour n'entraine pas le recalcul de formules utilisant cette cellule. Tu vois le tableau ?

Pour éviter cette vérification de formules je te conseille de passer en mode de calcul manuel en début de code avec

Code VBA :

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

Application.Calculation = xlCalculationManual

puis de rebasculer en mode de calcul automatique en fin de code avec

Code VBA :

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

Application.Calculation = xlCalculationAutomatic

.

Idem pour les vérifications de procédures événementielles. Excel vérifie à chaque mise à jour de cellule s'il doit faire une procédure qui en découle.

Utilise

Code VBA :

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

Application.EnableEvents = True

et

Code VBA :

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

Application.EnableEvents = False

pour bloquer cela le temps d'exécution de ton code.

En utilisant les tableaux mémoire Excel lit une seule fois et d'un seul coup les données de la plage de sélection de ta sélection (ta première boucle) et une seule fois et d'un seul coup les données de la plage "data" que tu lui définies. Ces données sont chargées en mémoire et il ne fait plus "d'allers/retours" sur tes feuilles. Ensuite tu reportes ton tableau mémoire modifié sur ta feuille (là encore en un seul coup). Donc fini les pertes de temps d'accès.

Enfin question praticité pour l'utilisateur je te conseille de créer dans ton classeur une feuille contenant en colonne les valeurs à remplacer comme ça l'utilisateur pourra facilement éventuellement en ajouter/supprimer et contrôler que toutes y sont. Actuellement tu les insères directement dans le code avec de multiples

Code VBA :

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

originalValue = findAndReplaceBettewSpacesOrMarker(originalValue, ReplaceValue, ReplaceValuewith, "\")

donc si un jour tu dois modifier, ajouter, supprimer l'une d'elle il faudra modifier le code.

Autre chose et après j'arrête : évite les types "variant". Si tes variables sont du texte alors utilises "string". Là encore tu perds du temps.

Pardon. J'ai l'impression de te démoraliser. Tu as demandé alors...

Si tu peux mettre un fichier anonymiser ce sera plus clair et on pourra regarder plus précisément.

Teste et dis nous.

**deedolith** · 27/02/2025, 10h07

Hello,

1er point: Ne pas tout faire en même temps (moins de ligne de code / instructions plus complexe n'est pas synonyme de performances).
Vires moi ces horribles "Application.ScreenUpdating = False", tant que ton code n'est pas fonctionnel, ils n'ont pas lieux d'exister.
"Premature optimisation is the root of all evils in software developpmen" (D.Knuth)
De plus, avant d'optimiser, il faut mesurer les performances / trouver les points de lenteur.

- Tu peux faire un dictionnaire de correspondances, ca évitera les répétitions d'instructions lourdingues / illisible / source d'erreur et augmentera la maintenabilité.
- Ensuite, capacité d'Excel, une plage de cellule peut être convertie en tableau 2D, parcourir ce dernier est autrement plus rapide que parcourir les cellules une par une.

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
Option Explicit
 
Public Sub FindAndReplace(ByRef Source As Excel.Range, ByRef Target As Excel.Range)
        '// Les 2 plages doivent avoir la même taille
    Debug.Assert Source.Rows.Count = Target.Rows.Count
    Debug.Assert Source.Columns.Count = Target.Columns.Count
 
        '// Lecture de la plage source et convertion en tableau 2D
    Dim Data() As Variant
    Data = Source.Value
 
        '// Recupere la liste des correspondances
    Dim Correspondances As Scripting.Dictionary
    Set Correspondances = GetCorrespondances
 
    Dim i As Long
    For i = LBound(Data, 1) To UBound(Data, 1)
        Dim j As Long
        For j = LBound(Data, 2) To UBound(Data, 2)
            Dim key As Variant      '// String
            For Each key In Correspondances.Keys
                Data(i, j) = Replace(Data(i, j), key, Correspondances(key))
            Next
                '// convertion en majuscules
            Data(i, j) = UCase(Data(i, j))
        Next
    Next
        '// Ecriture des données dans la plage cible
    Target.Value = Data
End Sub
 
Public Function GetCorrespondances() As Object      '// Scripting.Dictionary
    Dim Correspondances As Object       '// Scripting.Dictionary
    Set Correspondances = CreateObject("Scripting.Dictionary")
 
    Correspondances.Add "é", "e"
    Correspondances.Add "è", "e"
    Correspondances.Add "à", "a"
        '// liste à completer
 
    Set GetCorrespondances = Correspondances
End Function

Enfin, une fonction de test:

Code :

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

1
2
3
4
5
6
7
8
Public Sub test()
    Dim Ws As Excel.Worksheet
    Set Ws = ThisWorkbook.Worksheets("Feuil1")
 
    Dim Rng As Excel.Range
    Set Rng = Ws.Range("A1:B3")
    FindAndReplace Rng, Rng
End Sub

**jpvba** · 27/02/2025, 17h26

Re-Bonjour à vous tous,

Merci à deedolith et Alex020181 pour leur commentaire.

Effectivement, je suis d'accord qu'une boucle dans une boucle n'est vraiment pas optimal. Pour moi, de façon imaginer, ça fait un nœud. C'est Pour ça que j'ai fais le code sans double boucle mais j'arrive à un temps d'exécution plus lent. J'ai disons de la difficulté avec les dictionnaires et tableau mémoire, c'est pour ça que je vais étudier et essayé l'exemple de deedolith, c'est de l'or pour moi.

Pour les event et calculation, je n'étais pas au courant. On m'a déjà dit que le display était suffisant et en masquant celui-ci, excel ne fias plus d'affichage donc aucune tentative de recalculer les cellules. Je suis présentement le seul utilisateur du code, donc il n'y a pas de problème que les marqueurs soit dans le code.

Je vais également réviser mes variables.

Pour la liste des truc à remplacer, j'ai effectivement des ajout modifications donc l'avoir dans une feuille. Je ne sais pas si alors ma façon de procéder dans ma tentative plus longue sera bonne.

Non, non je ne suis pas décourager, seulement heureux d'avoir conseille et aide. Je n'ai pas un background informatique "pure" mais j'aime pouvoir avoir des outils performant et les créer. Je vous reviens d'ici peu (dès que je vais avoir un peu de temps) avec le code. J'ai disons pas mal de réunion mais entre celle-ci et mon rôle habituel, je vais mettre la main à la pâte

**jpvba** · 27/02/2025, 19h11

J'ai trouvé un peu de temps mais j'ai des questions.

Le code de deelolith ne considère pas les marqueurs. Il est primordiale de les garder afin de ne pas remplacer une partie d'un mot. Les marqueurs sont là afin de délimiter ce qui est remplaçable selon la ponctuation de la description. Sinon, j'aurais utilisé la fonction native de excel Replace.

En second lieu, le code est pour une sélection et non un range défini. Le seul range que l'on peut définir est les éléments du fichier data. Si je comprends bien le code suggéré, la sélection serais le dictionnaire et non les données de la feuille data. Est-ce que ça serait mieux de faire le contraire ?

**Alex020181** · 27/02/2025, 20h10

Voici un exemple en PJ.

La feuille "donnees_exemple" contient en colonne "A" les données à éventuellement modifier, en colonne "B" le témoin de modification demandé ("1" pour demander la modification) et en colonne "C" la liste finale des valeurs (modifiées et non modifiées). 32 758 lignes parmi lesquelles 16 209 demandes de modification.
La feuille "parametres" te permet de définir quelles sont les remplacements que tu veux faire (en "A" les anciens caractères et en "B" les nouveaux caractères). 8 cas de modification.

Tu peux compléter les feuilles avec tes cas précis en ajoutant ou supprimant des valeurs.

C'est un exemple simple pour comprendre. Je te laisse l'adapter à ton besoin précis.

Tu as un bouton pour lancer le code. A chaque fois la colonne "C" de "donnees_exemple" sera vidée et recomplétée.

Pour info sur mon modeste PC le code s'exécute en 0.4 seconde.

Teste et dis nous.

**tototiti2008** · 28/02/2025, 09h33

Bonjour,

Je ne comprend toujours que mal le cadre des remplacements, mais par exemple l'opérateur Like pourrait aider à faire les tests plutôt que de tester les caractères avant après un à un

https://learn.microsoft.com/fr-fr/of...6)%26rd%3Dtrue

**Philippe Tulliez** · 28/02/2025, 09h41

Bonjour,

Dans la cellule A1 j'ai "PARCOURS DU COMBATTANT" et dans B1 "CHEQUE DUMENT SIGNE". Dans la liste de critères DU serait remplacer par une cellule vide. Si j'applique un "Replace", j'aurai "PARCOURS COMBATTANT" et "CHEQUE MENT SIGNE".

J'ai ouvert votre fichier et en A1 (0.125") et en B1 (1/8")
Si votre fichier exemple ne correspond pas à vos explications, nous aurons des problèmes. Personnellement j'utiliserais Power Query

**jpvba** · 28/02/2025, 16h56

Bonjour à vous tous,

Je ne comprend toujours que mal le cadre des remplacements, mais par exemple l'opérateur Like pourrait aider à faire les tests plutôt que de tester les caractères avant après un à un

Je ne veux pas un LIKE mais une valeur identique ni proche ni une partie d'un mot. Il ne faut pas que le remplacement soit une partie d'un mot. LIKE ne délimite pas "mot entier et non partie d'un mot".

Si votre fichier exemple ne correspond pas à vos explications, nous aurons des problèmes. Personnellement j'utiliserais Power Query

Effectivement, j'ai donné des exemples à titre d'indication. Je travail dans un domaine auquel il y a des données qui peuvent être sensible pendant une période de temps. ON peut déjà identifier dans le type de domaine que je travail et c'est déjà beaucoup. La seule façon d'avoir pu partagé certaines données est d'en avoir censuré. Effectivement, Je veux une uniformité au niveau des mesures anglaise. Le système métrique est écrite avec des décimales et les mesures anglaises en fraction.
Il est donc normale que je veux convertir les champs ayant des décimales en fraction pour ceux-ci.

Pour une vrai exemple, après certaines expression j'utilise "seulement". Dans la base de donnée, je corrige certains endroit que c'Est plutôt écrit seul. Si je remplace seul par seulement, pour les champs ayant déjà seulement, je dois faire un autre rechercher / remplacer pour modifier les "seulementement" qui est causé Par le premier remplacement. JE ne voudrais pas avoir à exécuter 2 fois le même code et populer mon fichier data avec des erreurs causé par les remplacement. Lorsque le code sera optimale, je vais alors pouvoir mettre "seul" dans la colonne A et dans colonne B sur la même ligne "seulement". Les deux codes de mon premier poste le fait mais étant donné que c'est présentement trop lourd, je ne l'utilise pas. Pour une demande que j'ai traité hier , le temps d'exécution est d'environ 15 minutes. Parfois, ça plante lorsque c'est trop embourbé et je ne peux pas me permettre d'attendre aussi longtemps.

Oui la méthode "quick and dirty" serait de faire rouler 2 fois le codes et d'ajouter les erreurs généré par le premier passage, mais ça deviens interminable et non productif. C'Est comme d'avoir un médicament supplémentaire pour essayé de réduire les effets secondaires au lieu de changer celui-ci par un autre qui n'aurais pas ce type de désagrément. C'Est pour cette raison que j'élimine cette solution

Pour powerquery, j'ai seulement accès à power pivot et mes tentatives étaient infructueuses.

En espérant que ces explications vous sera utile.

Merci beaucoup pour vos intervention et commentaires

**Philippe Tulliez** · 28/02/2025, 17h14

Bonjour,

Effectivement, j'ai donné des exemples à titre d'indication. Je travail dans un domaine auquel il y a des données qui peuvent être sensible pendant une période de temps. ON peut déjà identifier dans le type de domaine que je travail et c'est déjà beaucoup. La seule façon d'avoir pu partagé certaines données est d'en avoir censuré.

C'est parfaitement compréhensible mais alors donnez des exemples par rapport à votre fichier joint sinon à quoi bon.

Pour powerquery, j'ai seulement accès à power pivot et mes tentatives étaient infructueuses.

Power Query est intégré dans excel depuis la version 2016 (voir l'onglet Données ou Data si version anglaise

Invité · 28/02/2025, 17h44

Je ne veux pas un LIKE mais une valeur identique ni proche ni une partie d'un mot. Il ne faut pas que le remplacement soit une partie d'un mot. LIKE ne délimite pas "mot entier et non partie d'un mot".

Utilise expression régulière, délimiter le mot recherché avec l'option \b cela permet de remplacer uniquement les mots entiers:

Code :

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

1
2
3
4
5
6
7
8
    Dim reg  As Object, Txt As String
    Set reg = CreateObject("VBScript.RegExp")
    reg.Pattern = "\bDU\b"
    reg.IgnoreCase = True
    reg.Global = True
 
    Txt = "PARCOURS DU COMBATTANT .. CHEQUE DUMENT SIGNE"
    MsgBox reg.Replace(Txt, "")

l'exemple affiche :
PARCOURS COMBATTANT .. CHEQUE DUMENT SIGNE

**tototiti2008** · 28/02/2025, 18h30

Re,

LIKE ne délimite pas "mot entier et non partie d'un mot".

Si, potentiellement, en moins court que RegEx mais en moins long que de tester espace, parenthèse, slash...

Code :

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

if Ucase(Texte) = "MOT" or ucase(Texte) like "*[!A-Z]MOT[!A-Z]*" or ucase(Texte) like "*[!A-Z]MOT" or ucase(Texte) like "MOT[!A-Z]*" then

**jpvba** · 28/02/2025, 18h50

Voici donc le code finale en combinant un peu la logique de tototiti2008 sans utiliser les RegEx (mais sans utiliser les likes

J'arrive donc au résultats voulu dans un temps très rapide.

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
Sub test6_preparerCelluleSelectedCell()
 
On Error GoTo errorhandler:
 
    Dim start As Single
    Dim finish As Single
 
    Dim valeur_cours As String
 
    Dim nbre_lignes_max_donnees_exemple As Long
    Dim nbre_lignes_max_parametres As Long
 
    Dim remplacement_cours As Variant
 
    Dim tablo_remplacements()
    Dim index_1_tablo_remplacements As Long
 
    Dim tablo_origine()
    Dim index_1_tablo_origine As Long
 
    Dim LettreProvLong As String
    Dim tablo_sortie() As String
 
    Dim dico_remplacement As Dictionary
    Set dico_remplacement = New Dictionary
 
    Dim tout_ProvLong As Range
 
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
 
    start = Timer
 
    LettreProvLong = TrouveLettreColonne([prov_long_travail])
 
    Set tout_ProvLong = Worksheets("Travail").Range(LettreProvLong & 2, LettreProvLong & LastLignUsedInColumn(LettreProvLong))
 
    'on nettoie les cellules
    NettoyerPlage tout_ProvLong
 
    '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
 
    nbre_lignes_max_parametres = Sheets("filtre_data").UsedRange.Rows.Count
    tablo_remplacements = Sheets("filtre_data").Range("A2:B" & nbre_lignes_max_parametres).Value
 
    For index_1_tablo_remplacements = 1 To nbre_lignes_max_parametres - 1
        dico_remplacement(tablo_remplacements(index_1_tablo_remplacements, 1)) = tablo_remplacements(index_1_tablo_remplacements, 2)
    Next index_1_tablo_remplacements
 
    nbre_lignes_max_donnees_exemple = Sheets("Travail").UsedRange.Rows.Count
    tablo_origine = tout_ProvLong.Value
    ReDim tablo_sortie(1 To nbre_lignes_max_donnees_exemple, 1 To 2)
 
    For index_1_tablo_origine = 1 To nbre_lignes_max_donnees_exemple - 1
        valeur_cours = tablo_origine(index_1_tablo_origine, 1)
 
        For Each remplacement_cours In dico_remplacement.Keys
            valeur_cours = Replace(" " & valeur_cours & " ", " " & remplacement_cours & " ", " " & dico_remplacement(remplacement_cours) & " ")
        Next
 
        tablo_sortie(index_1_tablo_origine, 1) = Trim(valeur_cours)
    Next index_1_tablo_origine
 
    Sheets("Travail").Range("E2:E" & nbre_lignes_max_donnees_exemple) = tablo_sortie
 
    'on pointe sur la feuille Travail afin de ne pas perdre la sélection
    Sheets("Travail").Select
 
    '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

J'ajoute donc un espace avant et après chaque mot ce qui fait mes délimiteurs et je les enlève par la suite

Merci a vous tous !!! Nous sommes passez de l'escargot à la formule 1 !!!

**Alex020181** · 28/02/2025, 19h50

Tu as résolu ton besoin. Tant mieux. J'allais me pencher dessus mais pas besoin alors.

**jpvba** · 28/02/2025, 21h32

Re-re Bonjour,

Pour être franc, j'ai hésiter à fermer la discussion étant donné qu'il y a un volet que cette sub ne répond pas et que je palie par autre chose présentement. Je ne sais pas si je devrais ré-ouvrir le file de discussion ou que je devrais re-faire un nouveau post en disant ce qu'il manque et devrait être ajouté.

Ce que j'ai en tête pourrais être solutionné par les RegEx. Il y a les "pouces" auquel les gens ont tendances à mettre "PO" au lieu du double guillemet qui est la représentation unique qui doit être utilisé dans ma base de donnée. Donc, étant donné que parfois, j'ai un nombre et immédiatement collé le PO, la passe-passe des champs vides avant et après ne fonctionnent plus. J'ai également les espaces superflux devant le double guillemet et autre cas que j'ai documentés.

Je laisse le code au cas où qu'on met dit de continuer le file, sinon, je vais refaire un nouveau post

(celui-ci pourrait être également optimisé avec les dictionnaires et ou tableau)

Code :

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

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
Function NettoyerPlage(rng As Range)
 
    Dim sourceCell As Range
 
    For Each sourceCell In rng
 
        sourceCell.Value = CleanAcc(sourceCell.Value)
 
        With sourceCell
 
            ' Remplacer les deux guillemets par le double guillemets et enlever les espaces
            .Value = Replace(.Value, " '", "'")
            .Value = Replace(.Value, " ''", Chr(34))
            .Value = Replace(.Value, "''", Chr(34))
            .Value = Replace(.Value, " " & Chr(34), Chr(34))
 
            ' Remplacer les non, sans et avec
            .Value = Replace(.Value, " NON ", " N/")
            .Value = Replace(.Value, " NON-", " N/")
            .Value = Replace(.Value, " SANS ", " S/")
            .Value = Replace(.Value, " SANS- ", " S/")
            .Value = Replace(.Value, " AVEC ", " A/")
 
            ' Enlever des caractères spéciaux
            .Value = Replace(.Value, Chr(188), "1/4")
            .Value = Replace(.Value, Chr(189), "1/2")
            .Value = Replace(.Value, Chr(190), "3/4")
            .Value = Replace(.Value, "+", " PLUS")
            .Value = Replace(.Value, "#", "NO ")
            .Value = Replace(.Value, "&", " ET ")
            .Value = Replace(.Value, "°", "DEG")
            .Value = Replace(.Value, " °", "DEG")
            .Value = Replace(.Value, "±", " PLUS OU MOINS ")
            .Value = Replace(.Value, " : ", " - ")
 
            ' Enlever les espaces devant les unités de mesures
            .Value = Replace(.Value, " CM", "CM")
            .Value = Replace(.Value, " MM", "MM")
            .Value = Replace(.Value, " KM", "KM")
            .Value = Replace(.Value, " PO ", Chr(34) & " ")
            .Value = Replace(.Value, " G ", "G ")
            .Value = Replace(.Value, " KG", "KG")
            .Value = Replace(.Value, "LBS", "LB")
            .Value = Replace(.Value, " LB", "LB")
            .Value = Replace(.Value, " US FL OZ", "US FL OZ")
            .Value = Replace(.Value, " UK FL OZ", "UK FL OZ")
            .Value = Replace(.Value, " ML", "ML")
            .Value = Replace(.Value, " L ", "L ")
            .Value = Replace(.Value, " FR ", "FR ")
            .Value = Replace(.Value, " PSI ", "PSI ")
            .Value = Replace(.Value, " UL ", "UL ")
            .Value = Replace(.Value, " MIL ", "MIL ")
 
            ' Enlever espace après première parenthèse et avant la dernière
            .Value = Replace(.Value, Chr(40) & " ", Chr(40))
            .Value = Replace(.Value, " " & Chr(41), Chr(41))
 
            ' Remplacer les virgules par des points pour les décimales
            .Value = Replace(.Value, ",0", ".0")
            .Value = Replace(.Value, ",1", ".1")
            .Value = Replace(.Value, ",2", ".2")
            .Value = Replace(.Value, ",3", ".3")
            .Value = Replace(.Value, ",4", ".4")
            .Value = Replace(.Value, ",5", ".5")
            .Value = Replace(.Value, ",6", ".6")
            .Value = Replace(.Value, ",7", ".7")
            .Value = Replace(.Value, ",8", ".8")
            .Value = Replace(.Value, ",9", ".9")
 
            ' Corriger les abréviations des mesures
            .Value = Replace(.Value, " AMPERES", "A")
            .Value = Replace(.Value, " AMPERE", "A")
            .Value = Replace(.Value, " DEGRES", "DEG")
            .Value = Replace(.Value, " DEGRE", "DEG")
            .Value = Replace(.Value, " GOUTTES", "GTTES")
            .Value = Replace(.Value, " GOUTTE", "GTTE")
 
            ' Corriger les erreurs de langue française
            .Value = Replace(.Value, "Œ", "OE")
 
        End With
 
        sourceCell.Value = Trim(sourceCell.Value)
 
    Next sourceCell
 
 
End Function

optimisation de Replace selon des séparateurs [XL-365]

Macros et VBA Excel

Vue hybride

Discussions similaires

Partager

Partager