[Résolu] VBA accélérer replace

[adel53]

bonjour

J'ai besoin de votre aide pour accélerer ce bout de code.
En gros je reçois de différent labo des analyses d'huile que j'importe et je retraite pour homégéniser les résultats de différents labo.

Cette partie de ma macro est celle qui consomme le plus de temps pouvez vous svp m'aider à l'optimiser

Sub Symboles()
    Columns("F:AP").Select
    Selection.Replace What:="9999", Replacement:="1", LookAt:=xlPart, _
    SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
    ReplaceFormat:=False

    Selection.Replace What:="~*", Replacement:="", LookAt:=xlPart, _
    SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
    ReplaceFormat:=False
    
    Selection.Replace What:=".", Replacement:=",", LookAt:=xlPart, _
    SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
    ReplaceFormat:=False
    
    Selection.Replace What:="-", Replacement:="", LookAt:=xlWhole, _
    SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
    ReplaceFormat:=False
    
    Selection.Replace What:="<1", Replacement:="0,9", LookAt:=xlPart, _
    SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
    ReplaceFormat:=False
    
    Selection.Replace What:="<0", Replacement:="0", LookAt:=xlPart, _
    SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
    ReplaceFormat:=False
    
    Selection.Replace What:="/", Replacement:=",", LookAt:=xlPart, _
    SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
    ReplaceFormat:=False
    
    Range("a1").Activate
    Application.Calculate
End Sub

Cette procédure aussi prends énormement de temps

Sub Formats()
    Dim derligne As Integer
    derligne = Range("B3000").End(xlUp).Row
    For Each c In Range("F2:AP" & derligne).Cells
        If c.Value <> "" Then
            c.Value = c.Value * 1
        End If
    Next
    Debug.Print "format " & ActiveSheet.Name
    Application.Calculate
End Sub

 

[laetitia90]

Re : VBA accélérer replace

bonjour adel53
un exemple pour la 1 qst.. code assez brut a voir en attendant mieux

pour la plage je prends la colonne f donc 6 adapte

Sub es()
Dim x As Variant, r As Long, c As Long
  With Application
 .Calculation = xlCalculationManual: .ScreenUpdating = 0: .DisplayAlerts = 0
    x = Range("f1:ap" & Cells(Rows.Count, 6).End(3).Row).Value
     For r = 1 To UBound(x, 1)
     For c = 1 To UBound(x, 2)
           x(r, c) = Replace(x(r, c), "9999", "1")
           x(r, c) = Replace(x(r, c), "~*", "")
           x(r, c) = Replace(x(r, c), ".", ",")
     'ect
     Next c: Next r
   Range("f1:ap" & Cells(Rows.Count, 6).End(3).Row).Value = x
  .Calculation = xlCalculationAutomatic: .ScreenUpdating = 1: .DisplayAlerts = 1
 End With
End Sub

 

[adel53]

Re : VBA accélérer replace

Merci laetitia je vais faire un test avec le temps d'exectution pour comparer les deux codes je poste les résultats une fois terminé

 

[pierrejean]

Re : VBA accélérer replace

Bonjour adel53

Tu souhaites gagner du temps
Cela tombe bien : nous aussi
Dans cette optique , tu nous prépares un petit fichier exemple a partir de ton fichier (sans données confidentielles )
Quelques dizaines de lignes devraient suffire

Edit : Salut Laetitia (pas rafraîchi assez vite)

 

[adel53]

Re : VBA accélérer replace

Voici un fichier exemple

Je dois gérer les analyses de 4 labos différents (CSV, Excel) une fois le fichier importé je procède à l'uniformisation des fichiers afin de faire du reporting derrière et décider si oui ou non une vidange doit être réalisé.

Laetitia J'ai erreur execution 13 avec votre macro

Merci pour votre aide

 

[laetitia90]

Re : VBA accélérer replace

re , salut Pierrejean

souci quand j'ouvre ton fichier liaison...

autrement essai de rajouter

  On Error Resume Next

en debut de code

mais plus le temps de rester desole

 

[pierrejean]

Re : VBA accélérer replace

Re

Une petite accélération peut-être avec cette macro:

Sub test()
debut = Timer
Application.Calculation = xlCalculationManual
tablo = Range("F2:AP" & Range("F" & Rows.Count).End(xlUp).Row)
voir = Array("9999", "~*", ".", "-", "<1", "<0", "/")
mettre = Array("1", "", ",", "", "0,9", "0", ",")
ReDim tabres(UBound(tablo, 1), UBound(tablo, 2))
For n = LBound(tablo, 1) To UBound(tablo, 1)
 For m = LBound(tablo, 2) To UBound(tablo, 2)
 tabres(n, m) = tablo(n, m)
   For p = LBound(voir) To UBound(voir)
     If InStr(tabres(n, m), voir(p)) <> 0 Then
         tabres(n, m) = Replace(tabres(n, m), voir(p), mettre(p))
     End If
   Next
 Next
Next
Range("F2").Resize(UBound(tabres, 1), UBound(tabres, 2)) = tabres
Application.Calculation = xlCalculationAutomatic
MsgBox (Timer - debut)
End Sub

teste et dis- nous

 

[adel53]

Re : VBA accélérer replace

merci laetitia je gagne du temps avec ton code merci bcp
Jean pierre je teste ta version tout de suite
Merci pour votre temps

 

[adel53]

Re : VBA accélérer replace

Merci votre aide
résultat
Ma macro => 0.22s
Laetitia=> 0.13s
Pierre jean =>0.35s

Je vais utiliser celle de laetitia pour mon projet merci pour votre aide

 

[Si...]

Re : [Résolu] VBA accélérer replace

salut

indépendamment de la durée (encore que ?) tu peux simplifier ton code

Sub Symboles()
  t = Timer
  Range("F1:AP" & [F60000].End(xlUp).Row)(3).SpecialCells(2).Select
  'pour accélérer surtout si tu as des fourmles
  With Application
    .Calculation = xlCalculationManual: .ScreenUpdating = 0: .DisplayAlerts = 0
  End With
  With Selection
    .Replace "9999", "1"
    .Replace "~*", ""
    .Replace ".", ","
    .Replace "-", ""
    .Replace "<1", "0,9"
    .Replace "<0", "0"
    .Replace "/", ","
   End With
   [A1].Activate
   Application.Calculation = xlCalculationAutomatic: Application.DisplayAlerts = 0
   MsgBox Timer - t
End Sub