XL 2019 Suppression espace de début et fin - Macro très rapide

[Bastien43]

Bonjour,

J'ai créé cette macro pour supprimer les espaces de début et de fin de chaque cellule (de toute une colonne : 12000 lignes)

Comment accélérer la macro, ce n'est pas rapide... ?? Existe-t-il un code plus rapide ?

Sub SupEspace()

Dim plage, cellule

Set plage = Range("D2:D12000")

For Each cellule In plage

    cellule.Value = Trim(cellule.Value)

Next cellule

End Sub

 

[patricktoulon]

re
contrairement a ce que je pensais et a la limite chez moi le post 25 fait concurrence a la mienne avec 0.74
avec l'affichage différé a cause du screen updating bloqué et le msgbox

et si je bloque le screenupdating avec la mienne je gagne 0.02 soit trois fois rien je suis à 0.60
tout ça me rend perplexe

 

[patricktoulon]

re
Bonsoir @Efgé
je fait juste les mêmes tests que @job75

 

[Efgé]

Re
Non. Tu dit que mon code ne fonctionne pas alors que ta vidéo parle clairement des espaces internes aux textes (ce qui n'était pas le sujet).
Pour la vitesse d'exécution du code, tu sais très bien que c'est sujet au PC, aux applications ouvertes ou non, à la vitesse du vent et si le Capricorne est en Cancer la situation peut empirer...
De toutes façons, je continue à penser que l'ajout de formules "vébéisées" est moins rapide qu'un traitement en mémoire avec un array.

Bon courage à tous

Cordialement

 

[patricktoulon]

re
oui il arrive parfois qu'une boucle sur un array est plus rapide
mais là rien ne se passe chez moi avec le post 3 (pas de trim left ou right ou dedans) tu le vois dans la capture
c'est ça que je pige pas j'ai essayé .value a la place de formulalocal et rien ne se passe
Nada : 54 centièmes de seconde mais rien n'est fait

 

[Efgé]

patricktoulon
Je laisse un ficier qui reprend les codes testés par Job75 pour que chacun puisse tester la même chose sur son PC.
J'ai mis les Application.ScreenUpdating au même endroit pour chaque code
Le fichier est fait avec 2007 et chaque code donne le résultat attendu.

Mon résultat :

Cordialement

 

[Bernard_XLD]

re,

Voila pour le mien sous 365 32 bits

Bien cordialement, @+

 

[patricktoulon]

re
en effet ma trim left/right est trop longue
par contre un truc que je pige pas du tout
c'est que ton code éfgé a l'identique dans un new classerur ouvert avec excel 2013 ne fonctionne pas
et ton fichier 2007 fonctionne
c'est pas la première fois que je constate ça surtout entre 365 et 2013
a un tel point que des fois je suis obligé de copier les données et code dans un new classeur 2013
pour pouvoir tester et des fois c'est choux blanc quand même
je vais revoir la formule trim left/right(j'ai 2 versions(celle que j'ai donné c'est pour 2016 )

 

[merinos]

Bonjour Bastien43

Par tableau (array)

Sub SupEspace2()

Dim plage As Range
Dim T As Variant
Dim i&, j&

Set plage = Range("D2:D12000")
T = plage
For i = LBound(T, 1) To UBound(T, 1)
    For j = LBound(T, 2) To UBound(T, 2)
        T(i, j) = Trim(T(i, j))
    Next j
Next i
plage.FormulaLocal = T
End Sub

Cordialement

Merci @Efgé ,

j'ai jamais etudie LBount et UBound...

mais l'exemple est clair.

 

[patricktoulon]

alors avec ton fichier ma trim left/right prend plusde 17 secondes
et avec mon fichier archive sur 100000 lignes elle met 2.56 secondes
c'est fou ça !!!!

 

[patricktoulon]

tiens j'ai ressorti l'archive
même avec le choix"select case " je suis a 2.45

Function ChangeAllCellpropertiesInRange(ByRef RnG As Range, prop As String)
    Dim R As Variant, Addr

    With RnG
        Addr = "'" & .Parent.Name & "'!" & .Address
        Select Case UCase(prop)


            'formule non matricielles
        Case "LOWER", "UPPER", "PROPER", "APPTRIM":
            prop = Replace(UCase(prop), "APPTRIM", "TRIM")
            R = Evaluate("IF(ISTEXT(" & Addr & ")," & UCase(prop) & "(" & Addr & "),REPT(" & Addr & ",1))")


            'formules matricielle
        Case "LTRIM": R = Evaluate("IF(ISTEXT(" & Addr & "),MID(" & Addr & ",FIND(MID(TRIM(" & Addr & "),1,2)," & Addr & ",1),LEN(" & Addr & ")),REPT(" & Addr & ",1))")

            'ancienne formule RTRIM qui fonctionne
            'Case "RTRIM": R = Evaluate("IF(ISTEXT(" & Addr & "),LEFT(" & Addr & ",FIND(""^^"",SUBSTITUTE(" & Addr & ",RIGHT(TRIM(" & Addr & "),1),""^^"",LEN(" & Addr & ")-LEN(SUBSTITUTE(" & Addr & ",RIGHT(TRIM(" & Addr & "),1),""""))))),REPT(" & .Address & ",1))")
            'nouvelle formule
        Case "RTRIM": R = Evaluate("IF(ISTEXT(" & Addr & "),LEFT(" & Addr & ",FIND(""§"",SUBSTITUTE(" & Addr & ",RIGHT(TRIM(" & Addr & "),1),""§"",LEN(" & Addr & ")-LEN(SUBSTITUTE(" & Addr & ",RIGHT(TRIM(" & Addr & "),1),""""))),1))," & Addr & ")")

        Case "TRIM":
            .Value = Evaluate("IF(ISTEXT(" & .Address & "),MID(" & .Address & ",FIND(MID(TRIM(" & .Address & "),1,2)," & .Address & ",1),LEN(" & .Address & ")),REPT(" & .Address & ",1))")
            R = Evaluate("IF(ISTEXT(" & .Address & "),MID(" & .Address & ",1,FIND(TRIM(RIGHT(SUBSTITUTE(TRIM(" & .Address & "), "" "", REPT("" "", 100)), 100))," & .Address & ",1)+LEN(TRIM(RIGHT(SUBSTITUTE(TRIM(" & .Address & "), "" "", REPT("" "", 100)), 100)))-1),REPT(" & .Address & ",1))")


        End Select
    End With

    ChangeAllCellpropertiesInRange = R
End Function

Sub testxx()
    [C1:C100000] = "    kldefkrei    efjfr   edferjgf   "
End Sub

Sub test()
    Dim DL, RnG As Range, tim&
    With Sheets(1)
        DL = .Cells(Rows.Count, 3).End(xlUp).Row
        Set RnG = .Range("C1:C" & DL)
        tim = Timer
        RnG.Value = ChangeAllCellpropertiesInRange(RnG, "trim")    'majuscule ou minuscule l'argument de propertie
    End With
   MsgBox Format(Timer - tim, "#0.00") 'message du temps passé a convertir
End Sub

 

[Efgé]

re
[...]ton code éfgé a l'identique dans un new classerur ouvert avec excel 2013 ne fonctionne pas
et ton fichier 2007 fonctionne [...]

Bonjour à toutes et tous, le fil, le forum

@patricktoulon, pourrais tu mettre le classeur 2013 avec mon code qui ne fonctionne pas. Je pourrais le tester sous 2007 aujourd'hui et sous 365 lundi pour tenter de comprendre.
Il doit bien y avoir une explication.

Cordialement

 

[Bernard_XLD]

Bonjour le fil, le forum

Par curiosité, j'ai aussi testé la matricielle de Job75 que je trouve sympa et concise, dommage qu'elle ne soit pas compatible toutes versions.

Bien cordialement, @+

 

[patricktoulon]

re
Bonjour @Efgé
c'est bon j'ai trouvé
en fait il faut enregistrer le fichier pour que ça marche quand il est encore "classeur1" sans nom ça ne marche pas

fait le test sur 2007 et 365 pour voir
ouvre un nouveau classeur
colle le code dans un nouveau module et lance les deux subs

Sub testx()
[A1:A100000] = "    k,goertfre    ezorfjezojfez    gfrejgr   "
End Sub
Sub SupEspace3()

Dim plage As Range
Dim T As Variant
Dim i&
Dim tim&
Set plage = Range("A1:A100000")
T = plage.Value
tim = Timer
For i = LBound(T) To UBound(T)
    T(i, 1) = Trim(T(i, 1))
Next i
plage.Value = T
MsgBox Format(Timer - tim, "#0.00")

End Sub

 

[patricktoulon]

re
et kiki cé le champignon toute catégorie

pour la formule de @job75
il n'est pas quelques chose d'évident qui saute aux yeux??.????????

Sub testx()
    [A1:A100000] = "    k,goertfre    ezorfjezojfez    gfrejgr   "
End Sub

Sub SupEspace()
With [A1:A100000]
    .Name = "P" 'plage nommée
    .Value = [TRIM(P)] 'SUPPRESPACE
End With
End Sub

non?
si je vous dit référence circulaire ou encore calcul itératif ,ça vous parle plus ça peut être
et oui ce que fait @job75 c'est bien utiliser une référence circulaire (plage=trim plage)

et ben bingo
DONC !!!! pour les versions antérieures a 2016 et 365 activer le calcul itératif

a ben je me suis bien levé moi tiens
ne prenez pas peur mais avec le calcul iteratif et la formule de @job75 je suis a 0.24
donc d'accords ca regule les espaces interne (c'est pas ce qui a été demandé)
mais bon c'est bon a savoir vous trouvez pas
bon allez café croissant a toute a l'heure

 

[job75]

Allons patricktoulon, pour qu'il y ait référence circulaire il faut au moins entrer une formule.

[TRIM(P)] est une matrice qui ne contient aucune formule, elle ne peut pas créer des références circulaires.