Bonjour a vous, j'utilise présentement une procédure qui est lente mais qui répond a mon besoin en terme de résultats. C'Est une combinaison de function qui pourrais etre fais autrement possiblement avec Regex, je pense

J'utilise une feuille excel lorsque je rencontre un mot, on le remplace par un abbréviation situé dans une feuille appelé data. DAns la feuille data, la colonne A nous avons le mot a remplacer, la colonne B comment remplacer le mot (i.e. l'abréviation), la colonne C le chiffre 1 a ceux que nous devons faire le remplacement car j'utilise la même feuille (data) pour un autre situation.

LA procédure préalablement remplace tout les accents et mets tout en majuscule les caractères des cellules selectionés et en enlevant les espace superflu (trim). PAr la suite, elle effectue le remplacement


Voici donc les codes des procédures et functions utiliser afin d'avoir le résultats voulus

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
Sub preparerCelluleSelectedCell()
 
Dim cell As Variant
 
Application.ScreenUpdating = False
 
For Each sourceCell In Selection
    sourceCell.value = StripAccent(UCase(CleanTrim(sourceCell.value)))
 
    '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" & LastLignUsed("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
 
End Sub
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
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 = "SZYAAAAAACEEEEIIIIDNOOOOOUUUUY"
 
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
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, "'")
 
findAndReplaceBettewSpacesOrMarkers = 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
18
19
20
21
22
23
24
25
26
27
Public Function findAndReplaceBettewSpacesOrMarker(originalValue, ReplaceValue, ReplaceValuewith, marker) 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


merci encore une fois pour votre aide qui es précieuses a mes yeux !!!!