Excel code VBA trop lent

Le 04/03/2021 à 12:40

Bonjour,

J'ai fait une macro en VBA elle fonctionne mais je suis débutant et ce n'est pas optimiser donc beaucoup trop lent.

Seriez-vous optimiser mon code ? merci d'avance.

Sub Macro1()
'
' Macro1 Macro

Worksheets("cmd").Unprotect
Worksheets("cmd2").Unprotect
Worksheets("art").Unprotect
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

ActiveWorkbook.Worksheets("cmd").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("cmd").Sort.SortFields.Add2 Key:=Range("C1:C150"), _
SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("cmd").Sort
.SetRange Range("A2:BX78")
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With

Sheets("filtre").Activate
Range("A20:B121").Select
Selection.Copy
Sheets("cmd").Select
Range("BY2").Select
ActiveSheet.Paste
Sheets("cmd").Activate
Columns("BY:BZ").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Columns("BY:BY").Select
Selection.Replace What:="#N/A", Replacement:="La commande n'est pas lier à un", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Columns("BZ:BZ").Select
Selection.Replace What:="#N/A", Replacement:="projet !", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False

Sheets("cmd").Activate
Columns("H:H").Select
Selection.Replace What:="51822", Replacement:="CDA", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Selection.Replace What:="51882", Replacement:="Verrou", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Selection.Replace What:="51884", Replacement:="Stock", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Selection.Replace What:="50049", Replacement:="Dépa", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Selection.Replace What:="51788", Replacement:="Intrusion", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Selection.Replace What:="51821", Replacement:="Incendie", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Selection.Replace What:="51823", Replacement:="Parlo", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Selection.Replace What:="51824", Replacement:="CCTV", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False

With Sheets("cmd") '<- feuille contenant les phrases à modifier à adapter eventuellement
dlf17 = .Cells(Rows.Count, 1).End(xlUp).Row
.Cells(1, 12).Resize(dlf17).Copy .Cells(1, 80)
Set plf17 = .Cells(1, 80).Resize(dlf17)
End With
With Sheets("frns") '<- feuille contenant la liste des mots à remplacer et les mots de remplacement à adapter eventuellement
dlf27 = .Cells(Rows.Count, 1).End(xlUp).Row
For p = 1 To dlf27
plf17.Replace .Cells(p, 1).Value, .Cells(p, 2).Value, xlPart
Next p
End With

With Sheets("cmd") '<- feuille contenant les phrases à modifier à adapter eventuellement
dlf1 = .Cells(Rows.Count, 1).End(xlUp).Row
.Cells(1, 6).Resize(dlf1).Copy .Cells(1, 79)
Set plf1 = .Cells(1, 79).Resize(dlf1)
End With
With Sheets("frns") '<- feuille contenant la liste des mots à remplacer et les mots de remplacement à adapter eventuellement
dlf2 = .Cells(Rows.Count, 1).End(xlUp).Row
For p = 1 To dlf2
plf1.Replace .Cells(p, 1).Value, .Cells(p, 2).Value, xlPart
Next p
End With

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

last_row = Worksheets("cmd").Cells(Rows.Count, 1).End(xlUp).Row

Dim Mot, Achever3, Test1, Date4, Commande5, Type6 As String
Dim Projet0 As String * 55
Dim ref2 As String * 30
Dim frns8 As String * 15
Dim i As Integer
Dim sepr As String

sepr = Chr(10)
For i = 2 To last_row

Sheets("cmd").Select
ref2 = Range("M" & i).Value
Achever3 = Range("CB" & i).Value
Date4 = Range("D" & i).Value
Commande5 = Range("C" & i).Value
Type6 = Range("H" & i).Value
Test1 = Range("BY" & i).Value
Projet0 = Range("BZ" & i).Value
frns8 = Range("CA" & i).Value
Mot = "Projet : " & Test1 & " " & Projet0 & sepr & "Article commander le " & Date4 & sepr & "Nom : " & ref2 & sepr & "N° de commande : " & Commande5 & " " & " " & " " & "Achever : " & Achever3 & sepr & "Type : " & Type6 & " " & "Fournisseur : " & frns8
Sheets("cmd").Select
Range("BX" & i - 0).Value = Mot
Next i

Sheets("vue").Activate
Range("F2:F3").Select
Selection.ClearContents
Worksheets("cmd").Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
Worksheets("cmd2").Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
Worksheets("art").Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
End Sub

Edit : merci de mettre le code entre balises avec le bouton </>

Le 04/03/2021 à 13:34

Bonjour,

Pas de soucis si tu avais un fichier même simplifié à soumettre.

Ce qu'il faut à mon sens pour accélérer, c'est

travailler avec des arrays (absorber d'un coup les valeurs, les traiter et retourner d'un coup le résultat = pas d'allers/retours incessants et chronophages avc la feuille)
éventuellement modifier les replace par des recherches dichotomiques ou l'utilisation du dictionnaire Scripting.Dictionary

Le 04/03/2021 à 13:41

Je vais regarder, pour faire une version simplifié parce qu'il y a pas mal de donné confidentiel. je vous envoie ça au plus vite

Le 04/03/2021 à 14:40

14stock-version-final-simple.zip (207.97 Ko)

Le 04/03/2021 à 14:42

Voilà j'ai essayer de te faire une version démo, mon code fonctionne mais c'est loin d'être top. merci du coup de main.

Dit toi qu'en vrai il y a dans les trois première table +- 10000 lignes dans chaque

Le 04/03/2021 à 17:05

despekill a écrit :
Dit toi qu'en vrai il y a dans les trois première table +- 10000 lignes dans chaque

Ce n'est pas un soucis.

J'ai une erreur au lancement !

Et en français, qu'est-ce que ta macro est sensée faire ?

Le 04/03/2021 à 17:10

Bonjour Despekill, Steelson.

Je me permet d'intervenir car visiblement, notre bon vieux

Application.Screenupdating = False
[...]
Application.Screenupdating = True

à été oublié ! C'est toujours quelques secondes de gagnées...

Bonne fin de journée à vous

Le 04/03/2021 à 17:44

@despekill

Pour le début, si tu figes les valeurs du nombre de lignes dans le tri, cela ne peut pas fonctionner, j'ai introduit derL, la dernière ligne

' 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

Le 04/03/2021 à 17:46

Etape suivante, remplace

    Columns("H:H").Select

    Selection.Replace What:="51822", Replacement:="CDA", LookAt:=xlPart, _
    SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
    ReplaceFormat:=False

    Selection.Replace What:="51882", Replacement:="Verrou", LookAt:=xlPart, _
    SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
    ReplaceFormat:=False

    Selection.Replace What:="51884", Replacement:="Stock", LookAt:=xlPart, _
    SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
    ReplaceFormat:=False

    Selection.Replace What:="50049", Replacement:="Dépa", LookAt:=xlPart, _
    SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
    ReplaceFormat:=False

    Selection.Replace What:="51788", Replacement:="Intrusion", LookAt:=xlPart, _
    SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
    ReplaceFormat:=False

    Selection.Replace What:="51821", Replacement:="Incendie", LookAt:=xlPart, _
    SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
    ReplaceFormat:=False

    Selection.Replace What:="51823", Replacement:="Parlo", LookAt:=xlPart, _
    SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
    ReplaceFormat:=False

    Selection.Replace What:="51824", Replacement:="CCTV", LookAt:=xlPart, _
    SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
    ReplaceFormat:=False

par

' remplacement des termes
Dim Data, dico As Object

    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

et dis moi si tu as déjà une (grosse) amélioration.

Je continuerai demain ...

Le 04/03/2021 à 19:39

Bonjour Gabin

Gabin37 a écrit :
Je me permet d'intervenir car visiblement, notre bon vieux
Application.Screenupdating = False
[...]
Application.Screenupdating = True
à été oublié ! C'est toujours quelques secondes de gagnées...

en effet ! MAIS, si tu veux gagner beaucoup, c'est du second ordre car si tu travailles avec des arrays tu travailles en mémoire vive sans faire d'allers/retours vers la feuille, et donc tu n'en a pas vraiment besoin.

Le 05/03/2021 à 08:29

Bonjour Steelson,

J'en déduit que tu as réussi a trouver le bug au lancement vue ton code. Merci pour ce que tu as déjà fait je vais essayer tout ça.

En gros je récupère 3 tables différente avec ODBC sur mon ERP, ce sont pour nos commandes fournisseurs j'ai besoin de récupérer et croiser c'est trois base pour avoir tout mes info comme tu as pue voir avec ma concaténation. (La première c'est la commande, la deuxième les articles lier a cette commande et la troisième le projet lier a cette commande)

le résultat souhaiter ce trouve dans vue, donc l'affichage des bonnes info a droite et a gauche plus les filtres sont le plus important.

Le 05/03/2021 à 08:39

Bonjour Steelson,

Pour les arrays j'aimerais bien mais je début et je n'y suis pas arriver. je ne comprenais pas bien

Le 05/03/2021 à 08:53

despekill a écrit :
Bonjour Steelson,
Pour les arrays j'aimerais bien mais je début et je n'y suis pas arriver. je ne comprenais pas bien

un exemple qui devrait te faire gagner du temps est ceci :

' remplacement des termes
Dim Data, dico As Object

    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

je vais regarder la fin du code aussi où il y a beaucoup d'interactions avec la feuille

Le 05/03/2021 à 09:19

Légèrement, mais mon code est beaucoup mieux déjà. Sur mon pc ça va en 1 secondes mais sur les pc normal du bureau faut compter 7 - 8 secondes c'est trop. Sur le gros du code faudrait faire des arrays tu serais m'aider la dessus ? faudrait savoir a qu'elle moment ça consomme le plus. OK merci d'avance pour la fin du code

Le 05/03/2021 à 11:20

despekill a écrit :
mon code est beaucoup mieux déjà. Sur mon pc ça va en 1 secondes

combien as-tu gagné ? de toute façon il faut aussi traiter la fin

despekill a écrit :
faudrait savoir a qu'elle moment ça consomme le plus. OK merci d'avance pour la fin du code

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

et je confirme que la dernière partie est aussi super lente

Le 05/03/2021 à 12:24

Pour la dernière partie ...

        Dim Mot, Achever3, Test1, Date4, Commande5, Type6 As String
        Dim Projet0 As String * 55
        Dim ref2 As String * 30
        Dim frns8 As String * 15
        Dim i As Integer
        Dim sepr As String

        sepr = Chr(10)
        Sheets("cmd").Select
        last_row = Worksheets("cmd").Cells(Rows.Count, 1).End(xlUp).Row
        Data = Sheets("cmd").Range(Cells(1, 1), Cells(last_row, 80))
        For i = 2 To UBound(Data)
            ref2 = Data(i, 13)          'Range("M" & i).Value
            Achever3 = Data(i, 80)      'Range("CB" & i).Value
            Date4 = Data(i, 4)          'Range("D" & i).Value
            Commande5 = Data(i, 3)      'Range("C" & i).Value
            Type6 = Data(i, 8)          'Range("H" & i).Value
            Test1 = Data(i, 77)         'Range("BY" & i).Value
            Projet0 = Data(i, 78)       'Range("BZ" & i).Value
            frns8 = Data(i, 79)         'Range("CA" & i).Value
            Mot = "Projet : " & Test1 & " " & Projet0 & sepr & "Article commander le " & Date4 & sepr & "Nom : " & ref2 & sepr & "N° de commande : " & Commande5 & " " & " " & " " & "Achever : " & Achever3 & sepr & "Type : " & Type6 & " " & "Fournisseur : " & frns8
            Data(i, 78) = Mot           'Range("BX" & i).Value = Mot
        Next i
        Sheets("cmd").Cells(1, 1).Resize(UBound(Data), UBound(Data, 2)) = Data

tu as donc ici une bonne démo de ce qu'il faut faire avec des arrays

je mets une copie de la feuille dans le tableau Data

        last_row = Worksheets("cmd").Cells(Rows.Count, 1).End(xlUp).Row
        Data = Sheets("cmd").Range(Cells(1, 1), Cells(last_row, 80))

je traite le tableau de la même façon que tu le faisais avec la feuille, j'ai laissé ton code en regard

        For i = 2 To UBound(Data)
            ref2 = Data(i, 13)          'Range("M" & i).Value
            Achever3 = Data(i, 80)      'Range("CB" & i).Value
            Date4 = Data(i, 4)          'Range("D" & i).Value
            Commande5 = Data(i, 3)      'Range("C" & i).Value
            Type6 = Data(i, 8)          'Range("H" & i).Value
            Test1 = Data(i, 77)         'Range("BY" & i).Value
            Projet0 = Data(i, 78)       'Range("BZ" & i).Value
            frns8 = Data(i, 79)         'Range("CA" & i).Value
            Mot = "Projet : " & Test1 & " " & Projet0 & sepr & "Article commander le " & Date4 & sepr & "Nom : " & ref2 & sepr & "N° de commande : " & Commande5 & " " & " " & " " & "Achever : " & Achever3 & sepr & "Type : " & Type6 & " " & "Fournisseur : " & frns8
            Data(i, 78) = Mot           'Range("BX" & i).Value = Mot
        Next i

je colle en retour le tableau dans la feuille en une seule fois

        Sheets("cmd").Cells(1, 1).Resize(UBound(Data), UBound(Data, 2)) = Data

Le 05/03/2021 à 12:26

J'ai divisé le temps par 10 sur chaque phase traitée

Mais je remarque qu'il reste encore ceci à accélérer :

    With Sheets("cmd") '<- feuille contenant les phrases à modifier à adapter eventuellement
        dlf17 = .Cells(Rows.Count, 1).End(xlUp).Row
        .Cells(1, 12).Resize(dlf17).Copy .Cells(1, 80)
        Set plf17 = .Cells(1, 80).Resize(dlf17)
    End With
    With Sheets("frns") '<- feuille contenant la liste des mots à remplacer et les mots de remplacement à adapter eventuellement
        dlf27 = .Cells(Rows.Count, 1).End(xlUp).Row
        For p = 1 To dlf27
            plf17.Replace .Cells(p, 1).Value, .Cells(p, 2).Value, xlPart
        Next p
    End With

    With Sheets("cmd") '<- feuille contenant les phrases à modifier à adapter eventuellement
        dlf1 = .Cells(Rows.Count, 1).End(xlUp).Row
        .Cells(1, 6).Resize(dlf1).Copy .Cells(1, 79)
        Set plf1 = .Cells(1, 79).Resize(dlf1)
    End With
    With Sheets("frns") '<- feuille contenant la liste des mots à remplacer et les mots de remplacement à adapter eventuellement
        dlf2 = .Cells(Rows.Count, 1).End(xlUp).Row
        For p = 1 To dlf2
            plf1.Replace .Cells(p, 1).Value, .Cells(p, 2).Value, xlPart
        Next p
    End With

qui représente maintenant 90% du temps

Le 05/03/2021 à 12:59

cette partie était la plus complexe pour suivre ton logigramme

je suis passé par 2 arrays : Data80 pour la colonne 80 et Data79 pour la colonne 79

j'ai travaillé sur ces arrays (au lieu de la feuille) et ensuite reporté les arrays à leur "place" dans la feuille

    With Sheets("cmd") '<- feuille contenant les phrases à modifier à adapter eventuellement
        dlf17 = .Cells(Rows.Count, 1).End(xlUp).Row
        .Cells(1, 12).Resize(dlf17).Copy .Cells(1, 80)
        Set plf17 = .Cells(1, 80).Resize(dlf17)
        data80 = plf17.Value
    End With
    With Sheets("frns") '<- feuille contenant la liste des mots à remplacer et les mots de remplacement à adapter eventuellement
        dlf27 = .Cells(Rows.Count, 1).End(xlUp).Row
        datafrns = .Range(.Cells(1, 1), .Cells(dlf27, 2)).Value
        For p = 1 To dlf27
            'plf17.Replace .Cells(p, 1).Value, .Cells(p, 2).Value, xlPart
            For x = 2 To UBound(data80)
                data80(x, 1) = Replace(data80(x, 1), datafrns(p, 1), datafrns(p, 2))
            Next
        Next p
    End With
    With Sheets("cmd") '<- feuille contenant les phrases à modifier à adapter eventuellement
        .Cells(1, 80).Resize(UBound(data80)) = Application.Transpose(data80)
    End With

    With Sheets("cmd") '<- feuille contenant les phrases à modifier à adapter eventuellement
        dlf1 = .Cells(Rows.Count, 1).End(xlUp).Row
        .Cells(1, 6).Resize(dlf1).Copy .Cells(1, 79)
        Set plf1 = .Cells(1, 79).Resize(dlf1)
        data79 = plf1.Value
    End With
    With Sheets("frns") '<- feuille contenant la liste des mots à remplacer et les mots de remplacement à adapter eventuellement
        dlf2 = .Cells(Rows.Count, 1).End(xlUp).Row
        datafrns = .Range(.Cells(1, 1), .Cells(dlf2, 2)).Value
        For p = 1 To dlf2
            'plf1.Replace .Cells(p, 1).Value, .Cells(p, 2).Value, xlPart
            For x = 2 To UBound(data80)
                data79(x, 1) = Replace(data79(x, 1), datafrns(p, 1), datafrns(p, 2))
            Next
        Next p
    End With
    With Sheets("cmd") '<- feuille contenant les phrases à modifier à adapter eventuellement
        .Cells(1, 79).Resize(UBound(data79)) = Application.Transpose(data79)
    End With

Le 05/03/2021 à 13:02

La macro complète telle que je l'ai faite, en espérant ne pas avoir supprimé certaines instructions

Sub MacroNew()

depart = Timer

    Worksheets("cmd").Unprotect
    Worksheets("cmd2").Unprotect
    Worksheets("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
Dim Data, dico As Object

    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

    With Sheets("cmd") '<- feuille contenant les phrases à modifier à adapter eventuellement
        dlf17 = .Cells(Rows.Count, 1).End(xlUp).Row
        .Cells(1, 12).Resize(dlf17).Copy .Cells(1, 80)
        Set plf17 = .Cells(1, 80).Resize(dlf17)
        data80 = plf17.Value
    End With
    With Sheets("frns") '<- feuille contenant la liste des mots à remplacer et les mots de remplacement à adapter eventuellement
        dlf27 = .Cells(Rows.Count, 1).End(xlUp).Row
        datafrns = .Range(.Cells(1, 1), .Cells(dlf27, 2)).Value
        For p = 1 To dlf27
            'plf17.Replace .Cells(p, 1).Value, .Cells(p, 2).Value, xlPart
            For x = 2 To UBound(data80)
                data80(x, 1) = Replace(data80(x, 1), datafrns(p, 1), datafrns(p, 2))
            Next
        Next p
    End With
    With Sheets("cmd") '<- feuille contenant les phrases à modifier à adapter eventuellement
        .Cells(1, 80).Resize(UBound(data80)) = Application.Transpose(data80)
    End With

    With Sheets("cmd") '<- feuille contenant les phrases à modifier à adapter eventuellement
        dlf1 = .Cells(Rows.Count, 1).End(xlUp).Row
        .Cells(1, 6).Resize(dlf1).Copy .Cells(1, 79)
        Set plf1 = .Cells(1, 79).Resize(dlf1)
        data79 = plf1.Value
    End With
    With Sheets("frns") '<- feuille contenant la liste des mots à remplacer et les mots de remplacement à adapter eventuellement
        dlf2 = .Cells(Rows.Count, 1).End(xlUp).Row
        datafrns = .Range(.Cells(1, 1), .Cells(dlf2, 2)).Value
        For p = 1 To dlf2
            'plf1.Replace .Cells(p, 1).Value, .Cells(p, 2).Value, xlPart
            For x = 2 To UBound(data80)
                data79(x, 1) = Replace(data79(x, 1), datafrns(p, 1), datafrns(p, 2))
            Next
        Next p
    End With
    With Sheets("cmd") '<- feuille contenant les phrases à modifier à adapter eventuellement
        .Cells(1, 79).Resize(UBound(data79)) = Application.Transpose(data79)
    End With

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

        Dim Mot, Achever3, Test1, Date4, Commande5, Type6 As String
        Dim Projet0 As String * 55
        Dim ref2 As String * 30
        Dim frns8 As String * 15
        Dim i As Integer
        Dim sepr As String

        sepr = Chr(10)
        Sheets("cmd").Select
        last_row = Worksheets("cmd").Cells(Rows.Count, 1).End(xlUp).Row
        Data = Sheets("cmd").Range(Cells(1, 1), Cells(last_row, 80))
        For i = 2 To UBound(Data)
            ref2 = Data(i, 13)          'Range("M" & i).Value
            Achever3 = Data(i, 80)      'Range("CB" & i).Value
            Date4 = Data(i, 4)          'Range("D" & i).Value
            Commande5 = Data(i, 3)      'Range("C" & i).Value
            Type6 = Data(i, 8)          'Range("H" & i).Value
            Test1 = Data(i, 77)         'Range("BY" & i).Value
            Projet0 = Data(i, 78)       'Range("BZ" & i).Value
            frns8 = Data(i, 79)         'Range("CA" & i).Value
            Mot = "Projet : " & Test1 & " " & Projet0 & sepr & "Article commander le " & Date4 & sepr & "Nom : " & ref2 & sepr & "N° de commande : " & Commande5 & " " & " " & " " & "Achever : " & Achever3 & sepr & "Type : " & Type6 & " " & "Fournisseur : " & frns8
            Data(i, 78) = Mot           'Range("BX" & i).Value = Mot
        Next i
        Sheets("cmd").Cells(1, 1).Resize(UBound(Data), UBound(Data, 2)) = Data

    Sheets("vue").Activate
    Range("F2:F3").Select
    Selection.ClearContents
    Worksheets("cmd").Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
    Worksheets("cmd2").Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
    Worksheets("art").Protect DrawingObjects:=True, Contents:=True, Scenarios:=True

Debug.Print 5, Timer - depart

End Sub

Le 05/03/2021 à 13:29

Merci pour ton code, je comprend mieux et j'ai adapter déjà par contre le dernier bout de code ne fonctionne pas. au lieu de mettre des bonne valeur c'est le nom de la colonne qui es répéter. Chez ta cela fonctionne regarde le résultat dan vue ?

2 3 4

Rechercher des sujets similaires à "code vba trop lent"