optimisation de Replace selon des séparateurs

Version imprimable

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:

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:

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:

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:

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 :D

27/02/2025, 05h00
Alex020181
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:

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:

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:

Application.Calculation = xlCalculationManual

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

Code:

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:

Application.EnableEvents = True

et

Code:

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:

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.

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:

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:

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

27/02/2025, 17h26
jpvba

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
27/02/2025, 19h11
jpvba

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 ?
27/02/2025, 20h10
Alex020181

1 pièce(s) jointe(s)

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.
27/02/2025, 20h36
jpvba

Bonjour Alex,

Effectivement, votre code est quand même assez rapide mais il ne tiens pas en compte des marqueurs (séparateurs). Par exemple je voudrait enlever les "PAR" dans mon texte mais sans que PARCOURS deviens COURS, donc a fin de savoir où couper on a mis des "marker" qui délimite les chaînes de caractère.

Je vais voir si je peux l'adapter avec ce que j'ai de fait à présent.

J'ai regarder avec copilot (je déteste les IA) et en incluant un dictionnaire à mon premier code c'est vraiment encore plus lent. Je vais également faire d'autre tentative avec le second code (boucle dans une boucle)
27/02/2025, 20h50
Alex020181

Mon code est un exemple pour comprendre. Je ne connais pas précisément ton besoin et en plus tu ne mets pas de fichier.

Je ne comprends pas ton histoire de marqueurs (ou séparateurs). Je comprends que tu veux faire ces remplacements uniquement dans des cas précis et sur une partie de la chaine initiale mais je ne sais pas comment tu définis comment et quand faire ou non le remplacement.

1 fichier serait le bienvenu avec un exemple de données initiales et les données en sortie que tu veux avec une explication du pourquoi du comment.
27/02/2025, 22h03
jpvba

1 pièce(s) jointe(s)

Re-Bonjour

Citation:

Je ne connais pas précisément ton besoin et en plus tu ne mets pas de fichier.

Je peux mettre un fichier en annexe mais habituellement dans beaucoup de forum, on ne permet pas de faire ceci dû au virus ou "l'imposition" de l'aide.

Pièce jointe 664963

Pour les marqueurs (séparateurs), voici un exemple simple :

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".

Ce qui n'a pas d'allure pour MENT . C'est sois que l'on dit dans la liste de remplacement " DU " " DU(" ")DU " "DU /", "/ DU" , et tout autre possibilité de caractères qui coupe le début et la fin de l'expression. Donc nous avons une répétition du même mot avec les marqueurs au début et à la fin. Afin de facilité et amincir la base de remplacement, nous avons mit les possibilités en définissants déjà ce qui est avant ou après une chaine à caractère à couper. Si il n'y a pas de marqueur, la chaine de caractères fait partie d'un mot.

Second exemple:

Donc afin d'avoir une uniformité dans ma base de donné on pourrait dire qu'au lieu de parler de songe, on voudrais parler de rêve. Donc "SONGE" deviendrait "REVE". Mais si quelque part dans une cellule j'ai le texte "MENSONGE" et que j'applique un Replace, j'obtiens "MENREVE". Il faut donc dire de ne pas remplacer l'expression SONGE dans une partie d'un mot. Afin de définir ce qui est un mot on peux dire que devant "SONGE il y a un espace, ou aucun si c'est au debut de la chaine de caractères et à la fin aussi (il est possible que j'aurais un autre caractères devant ou après qui n'est pas une lettre de l'alphabets).

Donc au lieu de dire que devant SONGE on doit exclure toute les lettres de l'alphabet au début et à la fin de celui-ci, on a mis les caractères possibles qui défini ce qui est un mot. Ayant ses marqueurs, excel comprend qu'il remplace un mot et non une partie de mot.

Au lieu d'Avoir une feuille pour les mots a remplacer avec se code et une autre feuille ayant des mots à remplacer dans d'autre circonstance. J'ai décidé de mettre le tout dans une seule et unique feuille. Donc la façon de dire que ce mot appartiens à ce code, il y a la colonne C ayant un 1.

merci beaucoup pour votre aide et commentaires, c'est très apprécié :D
28/02/2025, 09h33
tototiti2008

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
28/02/2025, 09h41
Philippe Tulliez

Bonjour,

Citation:

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
28/02/2025, 16h56
jpvba

Bonjour à vous tous,

Citation:

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".

Citation:

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
28/02/2025, 17h14
Philippe Tulliez

Bonjour,

Citation:

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.

Citation:

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

Citation:

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:

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

Re-Bonjour,

Merci à vous monsieur Tulliez, je vais lire sur power query lorsque je vais avoir un peu plus de temps ;)

Pour les RegEx, ça pourrais être la solution.

Je vous mets le code que j'ai appliqué les différentes suggestions du post. Il faudrait me guider pour RegEx et je crois que ce sera optimal.

Code:

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
Sub test4_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) = valeur_cours
 
    Next index_1_tablo_origine
 
 
    Sheets("Travail").Range("E2:E" & nbre_lignes_max_donnees_exemple) = tablo_sortie
 
    'on pointe sur la feuille Ravail afin de ne pas perdre la selction
 
     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

mrci à vous tous, nous sommes près du but ;)

28/02/2025, 18h30
tototiti2008

Re,

Citation:

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:

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

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:

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

28/02/2025, 19h50
Alex020181

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

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:

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