[VBA] - Accélérer vitesse d'exécution macro "remplacement"

Le 08/09/2020 à 12:02

Bonjour,

Dans certaines circonstances, j'ai encore quelques macros qui s’exécutent plutôt lentement. Celle-ci met 56 secondes pour 11 000 lignes en l’occurrence.

J'utilise des bases de données qui peuvent provenir de plusieurs sources et logiciels. Il arrive (souvent) que des accents aient été utilisés, mais ceux-ci sont transformés en symboles lors des différentes phases d'imports/exports. J'ai généralement ces symboles qui apparaissent une fois que j'ouvre la base de données.

J'ai donc une macro plutôt simple qui s'attèle à remplacer les symboles en lettres valides.

Ma base de donnée comporte 86 colonnes, toutes variabilisées. Pour accélérer la procédure j'ai fait une boucle de 1 à 10 qui va donner à une variable la valeur de chacune des colonnes qui nécessite une vérification (inutile sur les 86colonnes). En m'y prenant ainsi j'ai déjà gagné en vitesse d'exécution.

Savez-vous s'il y a un meilleur moyen de remplacer ces symboles, afin de gagner en temps d'exécution ?

Voici la macro :

Sub maj_UTF8()
Dim lras&, lcas&, a As Byte, cbl As Byte
With ActiveSheet
lras = .Cells(.Rows.Count, 1).End(xlUp).Row: lcas = .UsedRange.SpecialCells(xlCellTypeLastCell).Column
For a = 1 To 10
    If a = 1 Then If Va = 0 Then cbl = cib2
    If a = 2 Then If Va = 0 Then cbl = cib3
    If a = 3 Then If Va = 0 Then cbl = cib4
    If a = 4 Then If Vb = 0 Then cbl = cib11
    If a = 5 Then If Vb = 0 Then cbl = cib15
    If a = 6 Then If Vc = 0 Then cbl = cib17
    If a = 7 Then If Vd = 0 Then cbl = cib20
    If a = 8 Then If Vd = 0 Then cbl = cib21
    If a = 9 Then If Vd = 0 Then cbl = cib29
    If a = 10 Then If Ve = 0 Then cbl = cib24
        .Range(.Cells(1, cbl), .Cells(lras, cbl)).Replace What:="À", Replacement:="À", Lookat:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
        .Range(.Cells(1, cbl), .Cells(lras, cbl)).Replace What:="Ä", Replacement:="Ä", Lookat:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
        .Range(.Cells(1, cbl), .Cells(lras, cbl)).Replace What:="Â", Replacement:="Â", Lookat:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False

        .Range(.Cells(1, cbl), .Cells(lras, cbl)).Replace What:="Ç", Replacement:="Ç", Lookat:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False

        .Range(.Cells(1, cbl), .Cells(lras, cbl)).Replace What:="É", Replacement:="É", Lookat:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
        .Range(.Cells(1, cbl), .Cells(lras, cbl)).Replace What:="È", Replacement:="È", Lookat:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
        .Range(.Cells(1, cbl), .Cells(lras, cbl)).Replace What:="Ê", Replacement:="Ê", Lookat:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
        .Range(.Cells(1, cbl), .Cells(lras, cbl)).Replace What:="Ë", Replacement:="Ë", Lookat:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False

        .Range(.Cells(1, cbl), .Cells(lras, cbl)).Replace What:="ÃŽ", Replacement:="Î", Lookat:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False

        .Range(.Cells(1, cbl), .Cells(lras, cbl)).Replace What:="Ô", Replacement:="Ô", Lookat:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
        .Range(.Cells(1, cbl), .Cells(lras, lcas)).Replace What:="Ö", Replacement:="Ö", Lookat:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False

        .Range(.Cells(1, cbl), .Cells(lras, cbl)).Replace What:="Ù", Replacement:="Ù", Lookat:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
        .Range(.Cells(1, cbl), .Cells(lras, cbl)).Replace What:="Û", Replacement:="Û", Lookat:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
        .Range(.Cells(1, cbl), .Cells(lras, cbl)).Replace What:="Ãœ", Replacement:="Ü", Lookat:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False

        .Range(.Cells(1, cbl), .Cells(lras, cbl)).Replace What:="Ÿ", Replacement:="Ÿ", Lookat:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False

        .Range(.Cells(1, cbl), .Cells(lras, cbl)).Replace What:="é", Replacement:="é", Lookat:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
        .Range(.Cells(1, cbl), .Cells(lras, cbl)).Replace What:="à©", Replacement:="é", Lookat:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
        .Range(.Cells(1, cbl), .Cells(lras, cbl)).Replace What:="è", Replacement:="è", Lookat:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
        .Range(.Cells(1, cbl), .Cells(lras, cbl)).Replace What:="à¨", Replacement:="è", Lookat:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
        .Range(.Cells(1, cbl), .Cells(lras, lcas)).Replace What:="ê", Replacement:="ê", Lookat:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
        .Range(.Cells(1, cbl), .Cells(lras, cbl)).Replace What:="ë", Replacement:="ë", Lookat:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False

        .Range(.Cells(1, cbl), .Cells(lras, cbl)).Replace What:="ç", Replacement:="ç", Lookat:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False

        .Range(.Cells(1, cbl), .Cells(lras, cbl)).Replace What:="ï", Replacement:="ï", Lookat:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
        .Range(.Cells(1, cbl), .Cells(lras, cbl)).Replace What:="î", Replacement:="î", Lookat:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False

        .Range(.Cells(1, cbl), .Cells(lras, cbl)).Replace What:="ô", Replacement:="ô", Lookat:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
        .Range(.Cells(1, cbl), .Cells(lras, cbl)).Replace What:="ö", Replacement:="ö", Lookat:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
        .Range(.Cells(1, cbl), .Cells(lras, cbl)).Replace What:="Å“", Replacement:="œ", Lookat:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False

        .Range(.Cells(1, cbl), .Cells(lras, cbl)).Replace What:="û", Replacement:="û", Lookat:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
        .Range(.Cells(1, cbl), .Cells(lras, cbl)).Replace What:="ü", Replacement:="ü", Lookat:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
        .Range(.Cells(1, cbl), .Cells(lras, cbl)).Replace What:="ù", Replacement:="ù", Lookat:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False

        .Range(.Cells(1, cbl), .Cells(lras, cbl)).Replace What:="â", Replacement:="â", Lookat:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
        .Range(.Cells(1, cbl), .Cells(lras, cbl)).Replace What:="à¢", Replacement:="â", Lookat:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
        .Range(.Cells(1, cbl), .Cells(lras, cbl)).Replace What:="ä", Replacement:="ä", Lookat:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
        .Range(.Cells(1, cbl), .Cells(lras, cbl)).Replace What:="ÃÂ", Replacement:="à", Lookat:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
        .Range(.Cells(1, cbl), .Cells(lras, cbl)).Replace What:="Ã ", Replacement:="à", Lookat:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
        .Range(.Cells(1, cbl), .Cells(lras, cbl)).Replace What:="á", Replacement:="á", Lookat:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False

        .Range(.Cells(1, cbl), .Cells(lras, cbl)).Replace What:="ÿ", Replacement:="ÿ", Lookat:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False

        .Range(.Cells(1, cbl), .Cells(lras, cbl)).Replace What:="’", Replacement:="'", Lookat:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
        .Range(.Cells(1, cbl), .Cells(lras, cbl)).Replace What:="’", Replacement:="'", Lookat:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False

        .Range(.Cells(1, 1), .Cells(lras, lcas)).Replace What:="Ï", Replacement:="Ï", Lookat:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
Next a
End With
End Sub

Inutile de joindre un document Excel je suppose.

Merci de votre attention :)

Bonne journée !

Le 08/09/2020 à 12:39

Bonjour,

Celle-ci met 56 secondes pour 11 000 lignes en l’occurrence.

Une piste rapide en passant (qui devrait en principe te faire passer à < 1 seconde) :

  1. Commence par enregistrer toutes les cellules dans un tableau (array).
  2. Utilise ce tableau pour vérifier s'il y a des remplacements à faire (puisqu'il est infiniment plus rapide de travailler avec les données d'un tableau plutôt que celles des cellules) et modifie ensuite les cellules de la feuille uniquement lorsqu'un remplacement est nécessaire.

Cordialement,

Le 08/09/2020 à 13:36

Bonjour,

En effet, j'envisageais de passer par une variable tableau (comme pour le reste).

Mais comment faire ceci :

modifie ensuite les cellules de la feuille uniquement lorsqu'un remplacement est nécessaire.

Sans boucler sur l'ensemble des données du tableau ?

Sinon, je dois remplir un tableau avec les données qu'il y ait modification ou pas puis je colle ce tableau dans ma feuille à l'emplacement requis.

Je reviens un peu plus tard avec une macro.

Bonne journée !

Le 08/09/2020 à 13:55

Je m'y serais pris comme ça.

Mais ne fonctionne pas.

Dim lrcsv&, lccsv&, a%, aa As Variant, tab1()

With csv
    lrcsv = .Cells(.Rows.Count, 1).End(xlUp).Row: lccsv = .UsedRange.SpecialCells(xlCellTypeLastCell).Column
    aa = .Range(.Cells(1, 1), .Cells(lrcsv, lccsv))

ReDim tab1(1 To lrcsv, 1 To 2)
For a = 1 To UBound(aa)
    If UCase(aa(a, cib3)) Like "*(*" Or UCase(aa(a, cib3)) Like "*)*" Or UCase(aa(a, cib4)) Like "*(*" Or UCase(aa(a, cib4)) Like "*)*" Then
        tab1(a, 1) = aa(a, cib3).Replace(aa(a, cib3), "(", ""): tab1(a, 1) = tab1(a, 1).Replace(tab1(a, 1), ")", "")
        tab1(a, 2) = aa(a, cib4).Replace(aa(a, cib4), "(", ""): tab1(a, 2) = tab1(a, 1).Replace(tab1(a, 21), ")", "")
    Else
    tab1(a, 1) = aa(a, cib3): tab1(a, 2) = aa(a, cib4)
    End If
Next a
.Cells(2, cib3).Resize(lrcsv, 2) = tab1

'aa(a, 1).Replace what:="(", Replacement:="", Lookat:=xlPart

Je ne sais pas faire fonctionner de fonction "Replace" dans un Array.

EDIT:

En fait je pense avoir trouvé :

Dim lrcsv&, lccsv&, a%, aa As Variant

With csv
    lrcsv = .Cells(.Rows.Count, 1).End(xlUp).Row: lccsv = .UsedRange.SpecialCells(xlCellTypeLastCell).Column
    aa = .Range(.Cells(2, cib3), .Cells(lrcsv, cib4))

For a = 1 To UBound(aa)
    If UCase(aa(a, 1)) Like "*(*" Or UCase(aa(a, 1)) Like "*)*" Or UCase(aa(a, 2)) Like "*(*" Or UCase(aa(a, 2)) Like "*)*" Then
        aa(a, 1) = Replace(aa(a, 1), "(", ""): aa(a, 1) = Replace(aa(a, 1), ")", "")
        aa(a, 2) = Replace(aa(a, 2), "(", ""): aa(a, 2) = Replace(aa(a, 2), ")", "")
    End If
Next a
.Cells(2, cib3).Resize(lrcsv - 1, 2) = aa
End With

Je teste pour l'ensemble des infos que j'ai à traiter.

Le 08/09/2020 à 14:31
Le Drosophile a écrit :

Mais comment faire ceci :

modifie ensuite les cellules de la feuille uniquement lorsqu'un remplacement est nécessaire.

Par exemple, dans ta boucle tu copies une valeur A du tableau dans une variable B, tu appliques tes Replace sur cette variable B et tu vérifies à la fin si A <> B (si c'est le cas, la valeur a été modifiée par les remplacements et ça vaut donc la peine de modifier la cellule correspondante).

Le 08/09/2020 à 15:17

Re,

Que pensez-vous de ceci ?

Public Sub maj_dt_csv()
Dim lrcsv&, lccsv&, a%, b%, c%, aa As Variant, bb As Variant, Err, Cor, cbl As Byte

Err = Array("À", "Ä", "Â", "Ç", "É", "È", "Ê", "Ë", "ÃŽ", "Ô", "Ö", "Ù", "Û", "Ãœ", "Ÿ", "é", "à©", "è", "à¨", _
"ê", "ë", "ç", "ï", "î", "ô", "ö", "Å“", "û", "ü", "ù", "â", "à¢", "ä", "ÃÂ", "à ", "á", "ÿ", "’", "’", "Ï")
Cor = Array("À", "Ä", "Â", "Ç", "É", "È", "Ê", "Ë", "Î", "Ô", "Ö", "Ù", "Û", "Ü", "Ÿ", "é", "é", "è", "è", _
"ê", "ë", "ç", "ï", "î", "ô", "ö", "œ", "û", "ü", "ù", "â", "â", "ä", "à", "à", "á", "ÿ", "'", "'", "Ï")

With csv
    lrcsv = .Cells(.Rows.Count, 1).End(xlUp).Row: lccsv = .UsedRange.SpecialCells(xlCellTypeLastCell).Column
    aa = .Range(.Cells(2, cib3), .Cells(lrcsv, cib4)): bb = .Range(.Cells(2, cib29), .Cells(lrcsv, cib29))

For a = 1 To UBound(aa)
    If UCase(aa(a, 1)) Like "*(*" Or UCase(aa(a, 1)) Like "*)*" Or UCase(aa(a, 2)) Like "*(*" Or UCase(aa(a, 2)) Like "*)*" Then
        aa(a, 1) = Replace(aa(a, 1), "(", ""): aa(a, 1) = Replace(aa(a, 1), ")", "")
        aa(a, 2) = Replace(aa(a, 2), "(", ""): aa(a, 2) = Replace(aa(a, 2), ")", "")
    End If
    If InStr(bb(a, 1), ",") - 1 > 0 Then bb(a, 1) = Left(bb(a, 1), InStr(bb(a, 1), ",") - 1)

Next a
.Cells(2, cib3).Resize(lrcsv - 1, 2) = aa: .Cells(2, cib29).Resize(lrcsv - 1, 1) = bb

    aa = .Range(.Cells(2, 1), .Cells(lrcsv, lccsv))
    For a = 1 To UBound(aa)
        For c = 0 To UBound(Err)
            If UCase(aa(a, cib2)) Like "*" & Err(c) & "*" Then aa(a, cib2) = Replace(aa(a, cib2), Err(c), Cor(c))
            If UCase(aa(a, cib3)) Like "*" & Err(c) & "*" Then aa(a, cib3) = Replace(aa(a, cib3), Err(c), Cor(c))
            If UCase(aa(a, cib4)) Like "*" & Err(c) & "*" Then aa(a, cib4) = Replace(aa(a, cib4), Err(c), Cor(c))
            If UCase(aa(a, cib11)) Like "*" & Err(c) & "*" Then aa(a, cib11) = Replace(aa(a, cib11), Err(c), Cor(c))
            If UCase(aa(a, cib15)) Like "*" & Err(c) & "*" Then aa(a, cib15) = Replace(aa(a, cib15), Err(c), Cor(c))
            If UCase(aa(a, cib17)) Like "*" & Err(c) & "*" Then aa(a, cib17) = Replace(aa(a, cib17), Err(c), Cor(c))
            If UCase(aa(a, cib20)) Like "*" & Err(c) & "*" Then aa(a, cib20) = Replace(aa(a, cib20), Err(c), Cor(c))
            If UCase(aa(a, cib21)) Like "*" & Err(c) & "*" Then aa(a, cib21) = Replace(aa(a, cib21), Err(c), Cor(c))
            If UCase(aa(a, cib29)) Like "*" & Err(c) & "*" Then aa(a, cib29) = Replace(aa(a, cib29), Err(c), Cor(c))
            If UCase(aa(a, cib24)) Like "*" & Err(c) & "*" Then aa(a, cib24) = Replace(aa(a, cib24), Err(c), Cor(c))
        Next c
    Next a
    .Cells(2, 1).Resize(lrcsv - 1, lccsv) = aa
End With
End Sub

A plus tard

Edit : Je viens de voir votre message, ma solution est-elle plus lente que celle que vous proposez ? Cette macro s'exécute en 6 secondes.

Le 08/09/2020 à 16:04
Le Drosophile a écrit :

Que pensez-vous de ceci ?

...

Edit : Je viens de voir votre message, ma solution est-elle plus lente que celle que vous proposez ? Cette macro s'exécute en 6 secondes.

Si elle correspond à tes attentes, alors tout va bien (et c'est déjà beaucoup plus rapide qu'avant)

Par contre, sans avoir toutes les informations ni de pièce jointe, c'est un peu difficile de te donner un avis

Si tu veux aller plus loin, poste un fichier et explique précisément ce que dois faire la macro (à part les remplacements). Si nécessaire anonymise le fichier et ajoute artificiellement des caractères à remplacer.

Le 08/09/2020 à 16:45

Bonjour tout le monde !

Un essai à tester :

Sub maj_UTF8()

Dim i As Long, TblTxt() As Variant, CarSource() As Variant, CarCible() As Variant, L As Long, C As Integer

Application.ScreenUpdating = False: Application.Calculation = xlCalculationManual
CarSource = Array("À", "Ä", "Â", "Ç", "É", "È", "Ê", "Ë", "ÃŽ", "Ô", "Ö", "Ù", "Û", "Ãœ", "Ÿ", "é", "à©", "è", "à¨", "ë", "ç", "ï", "î", "ô", "ö", "Å“", "û", "ü", "ù", "â", "à¢", "ä", "ÃÂ", "à ", "á", "ÿ", "’", "’", "Ã")
CarCible = Array("À", "Ä", "Â", "Ç", "É", "È", "Ê", "Ë", "Î", "Ô", "Ö", "Ù", "Û", "Ü", "Ÿ", "é", "é", "è", "è", "ë", "ç", "ï", "î", "ô", "ö", "œ", "û", "ü", "ù", "â", "â", "ä", "à", "à", "á", "ÿ", "'", "'", "Ï")
TblTxt = Range("A1").CurrentRegion.Value
For i = LBound(CarSource) To UBound(CarSource)
    For L = LBound(TblTxt, 1) To UBound(TblTxt, 1)
        For C = LBound(TblTxt, 2) To UBound(TblTxt, 2)
            TblTxt(L, C) = Replace(TblTxt(L, C), CarSource(i), CarCible(i))
        Next C
    Next L
Next i
Range("A1").CurrentRegion.Value = TblTxt
Application.Calculation = xlCalculationAutomatic

End Sub
Le 08/09/2020 à 21:34

Bonsoir Pedro22,

Pour l'exécution de votre macro Excel m'affiche 21secondes.
Pour le moment mes 6 secondes l'emportent ! haha

Ce qui m’embête c'est que 6 secondes + 4 secondes + 7 secondes, etc. ça fait un code qui reste encore un peu lent à mon gout, je vais devoir reprendre chaque étape en passant par une variable tableau tout en regroupant les codes qui pourraient s'exécuter dans la même boucle.

Merci pour votre aide :)

Le 09/09/2020 à 08:42
Le Drosophile a écrit :

Pour l'exécution de votre macro Excel m'affiche 21secondes.
Pour le moment mes 6 secondes l'emportent ! haha

Bonjour !

J'ai tenté ma chance, ça marche pas à tous les coups !

Le 09/09/2020 à 09:17

Bonjour,

Peut-on voir le code d'import ?

EDIT :

Il faudrait que l'on puisse disposer du fichier* que tu importes. ça permettrait de voir ce qui cloche...

*anonymise le et réduit sa taille (1500 lignes suffiront je pense).

Rechercher des sujets similaires à "vba accelerer vitesse execution macro remplacement"