Excel code VBA trop lent

sinon (toujours hors sujet), fais le par paquets de 20 à la fois

Steelson, 3GB

C'est légèrement plus rapide mais le code que vous m'avez donner pour :

'ALIMENTATION TABLEAU REMPLACEMENT - MOTS A REMPLACER EN A, NOUVEAUX MOTS EN B
With Sheets("frns") '<<< en dur
dl = .Cells(.Rows.Count, 1).End(xlUp).Row
arrRmplt = .Range("A1:B" & dl).Value '<<< en dur
End With
'POUR EVITER LES REMPLACEMENTS INDESIRABLES
For i = LBound(arrRmplt) To UBound(arrRmplt)
t(i, 1) = "_" & t(i, 1) & "_"
Next i
'Alimentation tableau données (colonne source) - Boucle de remplacement sur chaque item - Collage (colonne destination)
With Sheets(NomFeuille)
dl = .Cells(.Rows.Count, 1).End(xlUp).Row
arrData = .Cells(1, colSource).Resize(dl).Value
For x = LBound(arrData) + 1 To UBound(arrData)
For p = LBound(arrRmplt) To UBound(arrRmplt)
arrData(x, 1) = Replace("_" & arrData(x, 1) & "_", arrRmplt(p, 1), arrRmplt(p, 2))
Next p
Next x
.Cells(1, colDest).Resize(UBound(arrData)) = arrData
End With

ne fonctionne pas ni chez l'un ni chez l'autre.

juste 3GB je pense que pour le tiens i manque que ta variable t n'est pas définie je pense

3GB a écrit :

Peut-être avec un sleep sinon, qui gère les millisecondes...

Function Delay(ms)
    Delay = Timer + ms / 1000
    While Timer < Delay: DoEvents: Wend
End Function

@despekill

mets ton code entre balise </>

Oui, je me suis emmêlé les pinceaux en effet..

Déjà, ça semble mieux ainsi :

With Sheets("frns") '<<< en dur
    dl = .Cells(.Rows.Count, 1).End(xlUp).Row
    arrRmplt = .Range("A1:B" & dl).Value '<<< en dur
End With
'POUR EVITER LES REMPLACEMENTS INDESIRABLES
For i = LBound(arrRmplt) To UBound(arrRmplt)
    arrRmplt(i, 1) = "_" & arrRmplt(i, 1) & "_"
Next i
'Alimentation tableau données (colonne source) - Boucle de remplacement sur chaque item - Collage (colonne destination)
With Sheets(NomFeuille)
    dl = .Cells(.Rows.Count, 1).End(xlUp).Row
    arrData = .Cells(1, colSource).Resize(dl).Value
    For x = LBound(arrData) + 1 To UBound(arrData)
        For p = LBound(arrRmplt) To UBound(arrRmplt)
            arrData(x, 1) = Replace("_" & arrData(x, 1) & "_", arrRmplt(p, 1), arrRmplt(p, 2))
        Next p
    Next x
    .Cells(1, colDest).Resize(UBound(arrData)) = arrData
End With

A voir...

il y a un problème sur cette ligne : arrData = .Cells(1, colSource).Resize(dl).Value

Ca prend combien de temps ?

Sur mon pc 1 à 2 secondes mais sur les ordi au boulot 5 à 6 secondes

despekill a écrit :

Sur mon pc 1 à 2 secondes mais sur les ordi au boulot 5 à 6 secondes

et avec le timer, si tu l'as conservé, que donnent les 5 étapes de ta macro ? sinon remets le

J'ai pas conserver tout ça j'ai juste adapter mon code avec le votre.

Tu serais me renvoyer tout svp

mets ceci aux endroits pertinents

sub machin()
depart = Timer
' ... ton code partie 1
Debug.Print Timer - depart
' ... ton code partie 2
Debug.Print Timer - depart
' ... ton code partie 3
Debug.Print Timer - depart
end sub

Voici un essai avec le blocage de la mise à jour écran (comme suggéré par Gabin) et le calcul mis en mode manuel le temps de l'exécution. J'ai enlevé les 2 .select de fin de code. Sinon, je ne pense pas qu'on gagnera beaucoup de temps. J'ai fait le pari de ne prendre que la colonne 78 en me disant qu'alimenter un tableau de 80 colonnes pourrait prendre un petit peu de temps mais je ne sais pas. Il faudra peut-être rechanger ça.

Il y a tout de même des petites opérations (tri, filtres, protection, ...) dont la durée est incompressible (enfin les protections et déprotections surtout). Je me dis qu'utiliser des tableaux structurés pourrait quand même faciliter les choses (le code déjà) et probablement abréger la durée d'exécution.

Sub MacroNew()

Dim Data, dico As Object
Dim Mot$, sepr$
Dim i As Integer

depart = Timer
application.screenupdating = false
application.calculation = xlCalculationManual

    Worksheets(array("cmd", "cmd2", "art")).Unprotect

' recopie et tri des cmd_frns dans cmd
    Worksheets("cmd").Range("A1:CC1000").ClearContents

    Sheets("cmd_frns").Cells.AdvancedFilter Action:=xlFilterCopy, CriteriaRange _
    :=Sheets("filtre").Rows("1:2"), CopyToRange:=Sheets("cmd").Range("A1"), Unique:=False

    derL = Sheets("cmd").Cells(Rows.Count, 1).End(xlUp).Row
    ActiveWorkbook.Worksheets("cmd").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("cmd").Sort.SortFields.Add Key:=Range("C2:C" & derL), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("cmd").Sort
        .SetRange Range("A1:BW" & derL)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

Debug.Print 1, Timer - depart

' remplacement des termes '<<<<<<< partie à voir !
    Data = Sheets("cmd").Range("H2:H" & derL)
    Set dico = CreateObject("Scripting.Dictionary")
    dico(51822) = "CDA"
    dico(51882) = "Verrou"
    dico(51884) = "Stock"
    dico(50049) = "Dépa"
    dico(51788) = "Intrusion"
    dico(51821) = "Incendie"
    On Error Resume Next
    For x = 1 To UBound(Data)
        Data(x, 1) = dico(Data(x, 1))
    Next
    On Error GoTo 0
    Sheets("cmd").Range("H2").Resize(UBound(Data), 1) = Data

Debug.Print 2, Timer - depart
'**************ICI******************
Remplacement "cmd", 12, 80 '<<<<
Remplacement "cmd", 6, 79 '<<<<
'***********************************
Debug.Print 3, Timer - depart

    Worksheets("art").Range("A1:BK1000").ClearContents
    Sheets("art_cmd").Cells.AdvancedFilter Action:=xlFilterCopy, CriteriaRange _
    :=Sheets("filtre").Rows("4:5"), CopyToRange:=Sheets("art").Range("A1"), Unique:=False

Debug.Print 4, Timer - depart

sepr = Chr(10)
with Sheets("cmd")
    last_row = .Cells(.Rows.Count, 1).End(xlUp).Row
    Data = .Cells(1, 78), resize(last_row).value
    For i = 2 To UBound(Data)
        Mot = "Projet : " & .cells(i, 77).value & " " & .cells(i, 78).value & sepr _
            & "Article commander le " & .cells(i, 4).value & sepr _
            & "Nom : " & .cells(i, 13).value & sepr _
            & "N° de commande : " & .cells(i, 3).value & "   " & "Achever : " & .cells(i, 80).value & sepr _
            & "Type : " & .cells(i, 8).value & " " & "Fournisseur : " & .cells(i, 79).value
        Data(i, 1) = Mot
    Next i
    .Cells(1, 78).Resize(UBound(Data)) = Data
end with

Sheets("vue").Range("F2:F3").ClearContents
Worksheets(array("cmd", "cmd2", "art")).protect DrawingObjects:=True, Contents:=True, Scenarios:=True
application.calculation = xlCalculationAutomatic
application.screenupdating = true

Debug.Print 5, Timer - depart

End Sub

Ce qui serait bien, c'est de mettre ceci en array sans aller piocher dans la feuille, c'est là que l'on fait exploser le temps de traitement

Mot = "Projet : " & .cells(i, 77).value & " " & .cells(i, 78).value & sepr _
            & "Article commander le " & .cells(i, 4).value & sepr _
            & "Nom : " & .cells(i, 13).value & sepr _
            & "N° de commande : " & .cells(i, 3).value & "   " & "Achever : " & .cells(i, 80).value & sepr _
            & "Type : " & .cells(i, 8).value & " " & "Fournisseur : " & .cells(i, 79).value

Justement, c'est ce que j'ai changé (c'est le pari).

En fait, je sais pas si le temps de traitement est plus long car je me dis qu'on ne manipule pas l'objet, on en demande la valeur et je pense, contrairement aux boucles sur les collections (ou il y a affectation d'un objet range à chaque itération) que le temps de traitement est identique. J'aimerais bien avoir la réponse.

Et je me dis que l'alimentation du tableau avec les 80 colonnes et je ne sais combien de lignes peut prendre du temps.

Mais de toute façon, ce n'est pas cette partie qui sera déterminante à mon avis. Ce sont les tris, filtres, protections, ...

il y a une erreur sur cette ligne

Data = .Cells(1, 78), resize(last_row).value

pour info c'est 76 et pas 78 ici

 Data(i, 78) = Mot 

l'autre c'est régler mais j'ai une erreur là aussi

Worksheets(Array("cmd", "cmd2", "art")).Unprotect

3GB envoie un fichier Excel si il fonctionne que je regarde exactement

J'ai ôter la protection pour test ça a l'air fluide mais les tri et les filtre pas trop juste a rapport a ce que j'vais fait et surtout l'affichage je comprend pas pourquoi des Under scores ?

J'utilise pas le fichier. Désolé, ce sont des fautes de frappe.

Data = .Cells(1, 78).resize(last_row).value

Pour l'erreur sur la ligne .unprotect, c'est un essai de ma part, pensant que ça marcherait. Si ça ne marche pas, il faut remettre les 3 lignes (idem à la fin du code où il y a reprotection). En cas d'erreur, peux-tu indiquer le message également ? Il n'y a aucun enjeu sur la rapidité du code à ces endroits de toute façon.

Cdlt,