Amélioration de procédure avec RegEx afin d'accroitre la performance

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:

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:

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:

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:

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:

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

Bonsoir,

Regexp est puissant fonctionnellement mais en revanche il est lent.

Boisgontier
http://boisgontierjacques.free.fr

Avec une nouvelle fonction versus un ancien ... j'ai vu une augmentation de performance. c'est vrai qu'avec une seule et unique situation, je ne peux généraliser :lol:

Est-ce que vous auriez des suggestions afin d'accroitre la vitesse d'exécution ???

en vous remerciant !!!

Bonsoir,

Généralités:
L'accès aux cellules individuellement ralentit l'exécution des programmes.
Dans la mesure où cela est possible, il faut;
- transférer des champs de cellules dans des Arrays,
- travailler sur ces Arrays
- et enfin restituer les champs modifiés.

L'utilisation de dictionnaires peut aussi contribuer à augmenter la vitesse des traitements.

Boisgontier
http://boisgontierjacques.free.fr

Est-ce que vous auriez un endroit auquel je pourrais en apprendre plus sur les dictionnaires et les array ??? Mon niveau de connaissance de VBA n'Est pas encore assez approfondi.

En vous remerciant !!!

N.B. Je vois votre site internet ... je vais également y jeter un cout d'œil afin de voir si je trouverai pas l'information (tuto)