Macro VBA "Remplacer par" amélioré

[nicopat]

Bonjour,

J'ai un gros fichier excel avec des formules dans tous les sens (plusieurs millions de formules).
Il nécessite quelques secondes à chaque recalcul et je souhaite l'accélérer.

J'ai lu qu'en théorie, certaines formules sont + rapides à calculées selon leur rédaction.
Exemple : RECHERCHEV(1;'Feuille'!A1:N1000;14;FAUX) sera + rapide que RECHERCHEV(1;'Feuille'!A:N;14;FAUX)
Je suppose qu'il en va de même pour toutes les formules faisant appel à des plages de cellules : RECHERCHEH(), SOMME(), MOYENNE(), etc...

Dans mon fichier, des centaines de milliers de formules sont concernées.


J'ai essayé la macro ci-dessous, sensée permettre de remplacer de manière sérialisée et successivement dans tous les feuillets du fichier toutes les occurences de plages mal définies dans les RECHERCHEV().
Par exemple, pour traiter les formules impliquant les plages de "a:a" à "a:g", voici la macro :

Public Sub Rempl()
Dim feuil As Worksheet
For Each feuil In ThisWorkbook.Worksheets
    feuil.Cells.Replace What:="a:a;", Replacement:="a1:a1500;", lookat:=xlPart
    feuil.Cells.Replace What:="a:b;", Replacement:="a1:b1500;", lookat:=xlPart
    feuil.Cells.Replace What:="a:c;", Replacement:="a1:c1500;", lookat:=xlPart
    feuil.Cells.Replace What:="a:d;", Replacement:="a1:d1500;", lookat:=xlPart
    feuil.Cells.Replace What:="a:e;", Replacement:="a1:e1500;", lookat:=xlPart
    feuil.Cells.Replace What:="a:f;", Replacement:="a1:f1500;", lookat:=xlPart
    feuil.Cells.Replace What:="a:g;", Replacement:="a1:g1500;", lookat:=xlPart
Next feuil
End Sub

Actuellement, cette macro ne semble pas fonctionner.

De plus, ce serait bien que la casse des expressions à remplacer ne soit pas prise en compte, c'est à dire que le code ci-dessus remplace "a:b;", mais aussi "A:b;", "a:B;", "A:B;"

Surtout, étant donné que certains feuillets utilisent jusqu'à la colonne QX, si je dois me taper toutes les combiaisons de plages possibles (car bien entendu, ces plages mal rédigées sont un peu partout dans le fichier et je ne sais pas précisément quelles sont ces plages), ça fait + de 11.000 "remplacer par" :

a:a
a:aa
a:ab
a:ac
a:ad
a:ae
a:af
a:ag
a:ah
a:ai
a:aj
a:ak
a:al
a:am
a:an
a:ao
a:ap
a:aq
a:ar
a:as
a:at
a:au
a:av
a:aw
a:ax
a:ay
a:az
a:b
etc...

sans compter si la casse entre en ligne de compte et sans compter le double aussi si je veut traiter les a:$a, a:$aa, a:$ab, etc...

Donc même si cela fonctionnait, les itérations de "remplacer par" ne seraient pas vraiment satisfaisantes non plus...

Donc ce qui résoudrait vraiment le problème serait un remplacement tous azimuts des expressions de type :
[1 ou 2 caractères texte] suivi de ":" ou ":$" et suivi de [1 ou 2 caractères texte]
par :
[1 ou 2 caractères texte] suivi de "1" suivi de ":" ou ":$" et suivi de [1 ou 2 caractères texte] suivi de "1500"


Attention de ne pas remplacer les expressions impliquant un chiffre : seulement [1 ou 2 caractères texte], pas [1 ou 2 nombres]

Merci de votre aide!

Nicole

 

[job75]

Bonjour nicopat, le forum,

J'ai supprimé le post que j'avais d'abord envoyé car j'y racontais des bêtises.

Effectivement avec des plages illimitées la durée d'exécution des formules peut être beaucoup plus longue.

Voyez le fichier joint et faites un double-clic sur P2 puis P3.

A+

 

[Lone-wolf]

Bonjour nicopat , job

C'est plus rapide avec une formule normale qu'avec une matricelle.

 

[job75]

Re, bonjour cher Lone-wolf,

Pour limiter les plages illimitées à la ligne 1500 testez cette macro :

Sub RemplacerPlages_Version1()
Dim rc&, w As Worksheet, c As Range, a As Range, s
rc = Worksheets(1).Rows.Count
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
On Error Resume Next
For Each w In Worksheets
  For Each c In w.UsedRange.SpecialCells(xlCellTypeFormulas)
    For Each a In c.Precedents.Areas 'antécédents
      If a.Rows.Count = rc Then
        s = Split(a.Address(0, 0), ":")
        If InStr(c.Formula, s(0) & ":" & s(1)) Then
          c.Replace s(0) & ":" & s(1), s(0) & "$1:" & s(1) & "$1500", xlPart
        Else
          c.Replace s(0) & ":$" & s(1), s(0) & "$1:$" & s(1) & "$1500", xlPart
        End If
      End If
Next a, c, w
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
End Sub

Cela prendra du temps car les formules sont traitées une par une.

Edit : je mets des $ (références absolues) devant 1 et 1500, cela pèse moins lourd s'il y a beaucoup de formules de même type.

A+

 

[job75]

Re,

Cette 2ème macro devrait être plus rapide si beaucoup de formules utilisent les mêmes plages illimitées :

Sub RemplacerPlages_Version2()
Dim rc&, w As Worksheet, P As Range, c As Range, a As Range, s
rc = Worksheets(1).Rows.Count
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
On Error Resume Next
For Each w In Worksheets
  Set P = Nothing
  Set P = w.UsedRange.SpecialCells(xlCellTypeFormulas)
  For Each c In P
    For Each a In c.Precedents.Areas 'antécédents
      If a.Rows.Count = rc Then
        s = Split(a.Address(0, 0), ":")
        P.Replace s(0) & ":" & s(1), s(0) & "$1:" & s(1) & "$1500", xlPart
        P.Replace s(0) & ":$" & s(1), s(0) & "$1:$" & s(1) & "$1500"
      End If
Next a, c, w
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
End Sub

Edit : j'ai ajouté les Application.EnableEvents et les Application.Calculation dans les 2 macros.

Dites-nous ce qu'il en est sur votre fichier.

A+

 

[job75]

Re,

J'ai testé avec la formule =RECHERCHEV(999;A:N;14;0) entrée dans 10 000 cellules.

La 1ère macro s'exécute en 27 secondes, la 2ème en 15 secondes.

S'il y "des centaines de milliers de formules" il faudra peut-être 20 ou 30 minutes.

A+

 

[job75]

Re,

En fait transformer les plage illimitées en plages limitées ne changera probablement rien aux durées d'exécution.

Les durées d'exécution de mon fichier (1) post #2 ne sont peut-être pas significatives.

Testez les cellules P2 et P3 de ce fichier (2) où j'ai rendu les formules volatiles.

A+

 

[job75]

Bonjour nicopat, Lone-wolf, le forum,

Pour finir je précise qu'en plus de la lenteur d'exécution des macros la plage de la formule =RECHERCHEV(999;Feuille!A:N;14;0) ne se transforme généralement pas si la formule n'est pas dans la feuille "Feuille".

Mes macros ne présentent donc pas un grand intérêt mais vous pouvez les essayer quand même.

Bonne journée.

 

[job75]

Re,

Je n'aime pas rester sur des macros non satisfaisantes, alors testez cette nouvelle version :

Sub RemplacerPlages_Version3()
Dim d As Object, i&, w As Worksheet, t, ncol%, j%, x$, k%, p%
'---liste des caractères---
Set d = CreateObject("Scripting.Dictionary")
d.CompareMode = vbTextCompare 'la casse est ignorée
For i = 65 To 90 'codes des lettres de A à Z
  d(Chr(i)) = ""
Next i
d("$") = "" 'ajout du caractère "$"
'---traitement des formules de chaque feuille---
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
On Error Resume Next 'sécurité
For Each w In Worksheets
  t = w.UsedRange.Formula 'matrice, plus rapide
  ncol = UBound(t, 2)
  For i = 1 To UBound(t)
    For j = 1 To ncol
      x = t(i, j)
      If Left(x, 1) = "=" Then
        If InStr(x, ":") Then
          For k = Len(x) To 1 Step -1
            If Mid(x, k, 1) = ":" Then
              p = k - 1
              While d.exists(Mid(x, p, 1))
                p = p - 1
              Wend
              If Mid(x, p + 1, 1) <> ":" Then
                p = k + 1
                While d.exists(Mid(x, p, 1))
                  p = p + 1
                Wend
                If Mid(x, p - 1, 1) <> ":" Then
                  x = Left(x, k - 1) & "$1" & Mid(x, k, p - k) & "$1500" & Mid(x, p)
                  k = k - 2
                End If
              End If
            End If
          Next k
          t(i, j) = x
        End If
      End If
  Next j, i
  w.UsedRange.Formula = t 'restitution
Next w
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
End Sub

Elle transforme toutes les plages illimitées et elle est beaucoup plus rapide.

Avec la formule =RECHERCHEV(999;Feuille!A:N;14;0) dans 100 000 cellules la durée d'exécution est de 10 secondes.

A+

 

[nicopat]

Merci beaucoup Job75,

Je teste tout de suite!!!

Nicole

 

[nicopat]

bon ben , déjà, merci Job75 !!!!

Néanmoins, il semble y avoir un problème : même d'autres formules que RechercheV() comme Moyenne() ou Somme() sont concernées.
Et j'ai peur que ça foute le bazar si des changements inappropriés sont opérés dans les plages dans des formules auxquelles je n'avais pas pensé.

C'est pour cela que j'ai indiqué la présence du ";" dans les expressions à remplacer, car cela permet de s'assurer que seule les recherchev() seront modifiées (je ne vois pas d'autre formule utilisant cet enchaînement de caractères).

Est-il possible d'apporter cette distinction STP?

Concernant le gain de temps, à ce stade il semble que je gagne quelques dixièmes de secondes à chaque recalcul, ce qui fera beaucoup à la fin de la journée.

PS : désolée, je me rends compte que le détail du ";" n'apparaît que dans la première partie de mon post et dans le code suggéré, mais j'avais oublié de le préciser dans la dernière partie en gras.

 

[job75]

Re,

Et j'ai peur que ça foute le bazar si des changements inappropriés sont opérés dans les plages dans des formules auxquelles je n'avais pas pensé.

Vous avez pris le temps de vraiment tester ? Si tous les UsedRange des feuilles ne dépassent pas la ligne 1500 il n'y a aucune raison que ma dernière version mette le bazar.

Sauf éventuellement s'il y a des textes entre guillemets.

Par exemple =TEXTE(A2/24;"hh:mm") sera transformé en =TEXTE(A2/24;"hh$1:mm$1500")

Si cette possibilité existe dites-le, on peut y remédier facilement.

Est-il possible d'apporter cette distinction STP?

Non car ce serait beaucoup trop compliqué.

Concernant le gain de temps, à ce stade il semble que je gagne quelques dixièmes de secondes à chaque recalcul

C'est donc PINUTS, et toute cette gymnastique n'a qu'un intérêt "intellectuel", comme je le prévoyais au post #7.

A+

 

[nicopat]

Vous avez pris le temps de vraiment tester ? Si tous les UsedRange des feuilles ne dépassent pas la ligne 1500 il n'y a aucune raison que ma dernière version mette le bazar.

oui, j'ai testé. Pour l'instant, je n'ai pas vu de problème, mais j'avais pensé à cette solution (mon post initial) en m'assurant qu'elle ne poserait pas de problème, alors que je n'ai pas vérifié que le remplacement sans prise en compte du ";" ne pose pas de problème.
D'où mon inquiétude, car je ne veux pas perturber le fonctionnement global du fichier par un effet de bord non maîtrisé sur telle ou telle fonction à laquelle je n'avais pas pensé (j'ai plusieurs millions de cellules avec des formules dans tous les sens et de très nombreuses fonctions faisant appel à des plages).

Si c'est trop compliqué, tant pis, je vais appliquer cette macro en croisant les doigts et serai vigilante si je vois survenir des trucs bizarres.

C'est donc PINUTS, et toute cette gymnastique n'a qu'un intérêt "intellectuel", comme je le prévoyais au post #7.

Dans mon cas, c'est énorme, car le fichier est recalculé des centaines de fois par heure.
Merci encore de m'avoir aidée.

 

[job75]

Re,

Utilisez plutôt cette 4ème version :

Sub RemplacerPlages_Version4()
Dim d As Object, i&, w As Worksheet, t, ncol%, j%, x$, k%, p%
'---liste des caractères---
Set d = CreateObject("Scripting.Dictionary")
d.CompareMode = vbTextCompare 'la casse est ignorée
For i = 65 To 90 'codes des lettres de A à Z
  d(Chr(i)) = ""
Next i
d("$") = "" 'ajout du caractère "$"
'---traitement des formules de chaque feuille---
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
For Each w In Worksheets
  t = w.UsedRange.Resize(w.UsedRange.Rows.Count + 1).Formula 'au moins 2 éléments
  ncol = UBound(t, 2)
  For i = 1 To UBound(t) - 1
    For j = 1 To ncol
      x = t(i, j)
      If Left(x, 1) = "=" Then
        If InStr(x, ":") Then
          For k = Len(x) - 1 To 3 Step -1
            If Mid(x, k, 1) = ":" Then
              If d.exists(Mid(x, k - 1, 1)) Then
                p = k + 1
                While d.exists(Mid(x, p, 1))
                  p = p + 1
                Wend
                x = Left(x, k - 1) & "$1" & Mid(x, k, p - k) & "$1500" & Mid(x, p)
              End If
            End If
          Next k
          t(i, j) = x
        End If
      End If
  Next j, i
  On Error Resume Next
  w.UsedRange.Formula = t 'restitution
  If Err.Number > 0 Then MsgBox "Restitution bloquée en feuille '" & w.Name & "' : une formule est à revoir..."
  On Error GoTo 0
Next w
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
End Sub

En effet certaines formules "tarabiscotées" peuvent bloquer la restitution des plages transformées qui suivent, par exemple :

=zzz:zzz
=SOMME(A:A:DECALER(A:A;;1))

Il vaut mieux en être averti mais il n'est pas possible d'indiquer la ou les formules fautives.

Nota : sur Excel 2007 il peut y avoir des problèmes avec Err.Number qui prend parfois la valeur 9 même sans erreur !

Dites-moi si le message fonctionne correctement chez vous (c'est à dire uniquement avec une formule tarabiscotée).

A+

 

[job75]

Bonjour nicopat, le forum,

La version précédente ne conserve pas les validations matricielles s'il y en a.

Voyez cette 5ème version qui utilise le Dictionary df pour mémoriser les plages illimités :

Sub RemplacerPlages_Version5()
Dim d As Object, df As Object, i&, w As Worksheet, t, ncol%, j%, x$, k%, p%, a, s
'---liste des caractères---
Set d = CreateObject("Scripting.Dictionary")
d.CompareMode = vbTextCompare 'la casse est ignorée
Set df = CreateObject("Scripting.Dictionary")
df.CompareMode = vbTextCompare 'la casse est ignorée
For i = 65 To 90 'codes des lettres de A à Z
  d(Chr(i)) = ""
Next i
d("$") = "" 'ajout du caractère "$"
'---traitement des formules de chaque feuille---
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
For Each w In Worksheets
  t = w.UsedRange.Resize(w.UsedRange.Rows.Count + 1).Formula 'au moins 2 éléments
  ncol = UBound(t, 2)
  For i = 1 To UBound(t) - 1
    For j = 1 To ncol
      x = t(i, j)
      If Left(x, 1) = "=" Then
        If InStr(x, ":") Then
          For k = 3 To Len(x) - 1
            If Mid(x, k, 1) = ":" Then
              If d.exists(Mid(x, k - 1, 1)) Then
                p = k + 1
                While d.exists(Mid(x, p, 1))
                  p = p + 1
                Wend
                df(Mid(x, k - 1, p - k + 1)) = "" 'mémorisation sans doublon
              End If
            End If
          Next k
        End If
      End If
  Next j, i
  If df.Count Then
    a = df.keys
    For i = 0 To UBound(a)
      s = Split(a(i), ":")
      w.UsedRange.Replace a(i), s(0) & "$1:" & s(1) & "$1500", xlPart 'remplacement dans toute la feuille
    Next i
    df.RemoveAll 'RAZ du Dictionary
  End If
Next w
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
End Sub

Avantages :

- les validations matricielles sont conservées

- il n'y a plus de problème avec les formules "tarabiscotées".

Inconvénient : la durée d'exécution dépend de df.Count et peut être rédhibitoire.

A+