Code VBA ralentissant une macro

Le 29/09/2017 à 00:35

Bonjour

Après avoir procédé par élimination, j'ai trouvé le code qui me ralentit considérablement ma macro.

Il s'agit d'un code que j'ai mis et qui travaille sur une feuille d'un classeur, puis le même code sur une deuxième feuille et qui me permet de transformer le contenu d'une cellule de x lettres en seulement 3 lettres dans une autre cellule ( exemple : CNE1ER = CNE) et ce sur environ 300 lignes.

Ci joint le code qui pourrait peut être être modifier ??

[code]'Dim a As String

'Dim b As String

'Dim c As String

'Dim LiFin(2) As Long

'Dim x As Long

'Dim y As Long

'LiFin(1) = Cells(Rows.Count, 4).End(xlUp).Row

'LiFin(2) = Cells(Rows.Count, 1).End(xlUp).Row

'For x = 1 To LiFin(2)

'c = c & "µ" & Cells(x, 1)

'Next x

'c = c & "µ"

'For x = 2 To LiFin(1)

'a = Cells(x, 4)

'If InStr(1, c, a) > 0 Then

'Cells(x, 3) = a

'Else

'Cells(x, 3) = Mid(a, 1, 3)

'End If

'Next x

/code]

[code]'Dim a As String

'Dim b As String

'Dim c As String

'Dim LiFin(2) As Long

'Dim x As Long

'Dim y As Long

'LiFin(1) = Cells(Rows.Count, 4).End(xlUp).Row

'LiFin(2) = Cells(Rows.Count, 1).End(xlUp).Row

'For x = 1 To LiFin(2)

'c = c & "µ" & Cells(x, 1)

'Next x

'c = c & "µ"

'For x = 2 To LiFin(1)

'a = Cells(x, 4)

'If InStr(1, c, a) > 0 Then

'Cells(x, 3) = a

'Else

'Cells(x, 3) = Mid(a, 1, 3)

'End If

'Next x

/code]

Le 29/09/2017 à 06:04

Bonjour Tacentaure

Je n'ai rien compris de la finalité de ton code "qui ralentit", mais pour accélérer (à mon avis) un traitement de ce genre...

Il faut créer une fonction dans un module standard et non dans chaque module de feuille, quelque chose de ce genre...

Function TransformeEnTroisLettres(cel As Range)
Dim...
    Application.Volatile ' pour permettre la prise en compte de cette fonction dans les calculs automatiques
    ' ici le code de la fonction
    TransformeEnTroisLettres = resultatDuTraitementRealiseCiDesus
End Function

Et ensuite à chaque fois que tu as besoin de réaliser ce "3 lettres" tu utilises la fonction TransformeEnTroisLettres comme une formule Excel classique :

= TransformeEnTroisLettres( <= une référence de cellule )

Le 29/09/2017 à 06:53

Bonjour,

Poste un classeur avec tes chaînes de lettres, ça sera plus facile pour t'aider. Par exemple, je ne comprend pas l'intérêt de l'insertion du caractère "µ" ? Qui ensuite n'est pas utilisé !

Le 29/09/2017 à 08:26

Le fichier qui cache les lettres en exemple.

Placé dans un userform,le code ralentit considérablement la macro globale

14cacher-des-lettres.xlsm (18.30 Ko)
Le 29/09/2017 à 08:50

Bonjour Tacentaure,

Idem je ne comprend pas l'interet du caractere µ dans ta macro, tu pourrais nous éclairer?

Le mieux est probablement de passer par une fonction, ou a defaut dans un premier temps arreter de travailler sur ta feuille! L'idée en VBA c'est d'intéragir un minimum avec l'interface excel.

Par exemple, récupérer une valeur, ou 1000 valeurs sur une feuille mettra grosso modo le meme temps d'execution. Il vaut mieux du coup récupérer la totalité de tes valeurs en un coup en les passant dans un tableau VBA, puis traiter ton tableau VBA et coller le resultat.

Ta macro interagis avec chaques cellules de ta colonne, et je pense que c'est une des causes du ralentissement.

Ci joint un exemple de tableau avec ta macro :

  • Dans un premier temps on recupere la totalité de tes valeurs, qu'on stocke dans un tableau.
  • On execute ton code sur le tableau VBA, plus du tout sur la feuille
  • A la fin du traitement, on colle le tableau
Sub Bouton1_Cliquer()

    Dim a As String
    Dim b As String
    Dim c As String
    Dim LiFin(2) As Long
    Dim x As Long
    Dim y As Long

    Dim tabentree() As Variant
    Dim lg As Long

    LiFin(1) = Cells(Rows.Count, 2).End(xlUp).Row
    LiFin(2) = Cells(Rows.Count, 6).End(xlUp).Row

'On dimensionne le tableau en fonction de la colonne la plus grande
    If LiFin(1) >= LiFin(2) Then
    lg = LiFin(1)
    Else
    lg = LiFin(2)
    End If

'On recupere la totalité de tes valeurs, qu'on stocke dans un tableau
    tabentree = ThisWorkbook.Sheets("feuil1").Range("A1:H" & lg).Value

'On execute ta macro sur le tableau    
    For x = 1 To LiFin(2)
        c = c & "µ" & tabentree(x, 6)
    Next x

    c = c & "µ"

    For x = 2 To LiFin(1)
        a = tabentree(x, 2)
        If InStr(1, c, a) > 0 Then
                tabentree(x, 8) = a
            Else
                tabentree(x, 8) = Mid(a, 1, 3)
        End If
    Next x

'On colle le tableau
       ThisWorkbook.Sheets("feuil1").Range("A1:H" & lg).Value = tabentree

End Sub

Yann

Le 30/09/2017 à 08:55

Bonjour,

Testes ce code pour voir si il te convient :

Sub Bouton1_Cliquer()

    Dim TblExep
    Dim TblMots
    Dim I As Long
    Dim Exeption As String

    With Worksheets("Feuil1"): TblMots = .Range(.Cells(2, 2), .Cells(.Rows.Count, 2).End(xlUp)): End With
    With Worksheets("Feuil1"): TblExep = .Range(.Cells(2, 6), .Cells(.Rows.Count, 6).End(xlUp)): End With

    For I = 1 To UBound(TblExep): Exeption = Exeption & TblExep(I, 1): Next I

    For I = 1 To UBound(TblMots)

        If InStr(Exeption, TblMots(I, 1)) = 0 Then TblMots(I, 1) = Left(TblMots(I, 1), 3)

    Next I

    Range(Cells(2, 8), Cells(UBound(TblMots) + 1, 8)) = TblMots

End Sub
Le 30/09/2017 à 20:52

Bonjour

Merci pour le code Thèse, il a l'air de moins perturber ma macro. Super

Cependant j'ai ce code ci dessous qui lui ralentit l'ouverture de ma feuille, je ne sais pas si on peut aussi remédier à ce problème ??

Il permet de reporter une date inscrite dans une cellule dans une autre cellule en fonction d'une date

[code]Private Sub Worksheet_Activate()

Dim derl As Long

' définir la dernière ligne en fonction de la Colonne A

derl = ActiveSheet.Cells(Application.Rows.Count, "A").End(xlUp).Row

' nouvelle version de la Copie

'Range("O3:X3").Copy Destination:=Range("O4:O" & derl)

'T 2018

Range("U39").FormulaArray = "=IFERROR(SMALL(IF(RC7:RC16-R35C7>0,RC7:RC16,""""),COLUMN(R2C[-20])),0)"

Range("U39").Copy Destination:=Range("V39:AD39")

Range("U39:AD39").Copy Destination:=Range("U40:U" & derl)

'T 2019

Range("AI39").FormulaArray = "=IFERROR(SMALL(IF(RC21:RC30-R35C8>0,RC21:RC30,""""),COLUMN(R2C[-34])),0)"

Range("AI39").Copy Destination:=Range("AJ39:AR39")

Range("AI39:AR39").Copy Destination:=Range("AI40:AI200")

'T 2020

Range("Aw39").FormulaArray = "=IFERROR(SMALL(IF(RC35:RC44-R35C9>0,RC35:RC44,""""),COLUMN(R2C[-48])),0)"

Range("AW39").Copy Destination:=Range("AX39:BF39")

Range("AW39:BF39").Copy Destination:=Range("AW40:AW200")

'T 2021

Range("BK39").FormulaArray = "=IFERROR(SMALL(IF(RC49:RC58-R35C10>0,RC49:RC58,""""),COLUMN(R2C[-62])),0)"

Range("BK39").Copy Destination:=Range("BL39:BT39")

Range("BK39:BT39").Copy Destination:=Range("BK40:BK200")

/code]

Le 01/10/2017 à 08:59

Bonjour,

Je ne me suis pas penché sur tes formules mais en bloquant le calcul automatique le code s'exécutera un peu plus vite, le calcul en mode automatique sera rétabli en fin de procédure :

Private Sub Worksheet_Activate()

    Dim derl As Long
    ' définir la dernière ligne en fonction de la Colonne A
    derl = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
    ' nouvelle version de la Copie
    'Range("O3:X3").Copy Destination:=Range("O4:O" & derl)

    'mets le calcul en manuel
    Application.Calculation = xlCalculationManual

    'T 2018
    Range("U39").FormulaArray = "=IFERROR(SMALL(IF(RC7:RC16-R35C7>0,RC7:RC16,""""),COLUMN(R2C[-20])),0)"
    Range("U39").Copy Destination:=Range("V39:AD39")
    Range("U39:AD39").Copy Destination:=Range("U40:U" & derl)

    'T 2019
    Range("AI39").FormulaArray = "=IFERROR(SMALL(IF(RC21:RC30-R35C8>0,RC21:RC30,""""),COLUMN(R2C[-34])),0)"
    Range("AI39").Copy Destination:=Range("AJ39:AR39")
    Range("AI39:AR39").Copy Destination:=Range("AI40:AI200")

    'T 2020
    Range("Aw39").FormulaArray = "=IFERROR(SMALL(IF(RC35:RC44-R35C9>0,RC35:RC44,""""),COLUMN(R2C[-48])),0)"
    Range("AW39").Copy Destination:=Range("AX39:BF39")
    Range("AW39:BF39").Copy Destination:=Range("AW40:AW200")

    'T 2021
    Range("BK39").FormulaArray = "=IFERROR(SMALL(IF(RC49:RC58-R35C10>0,RC49:RC58,""""),COLUMN(R2C[-62])),0)"
    Range("BK39").Copy Destination:=Range("BL39:BT39")
    Range("BK39:BT39").Copy Destination:=Range("BK40:BK200")

    'rétabli en automatique de cette façon, la feuille sera calculée en une seule fois et non à chaque insertion de formule
    Application.Calculation = xlCalculationAutomatic

End Sub
Le 01/10/2017 à 13:17

Bonjour (...)

Je n'ai pas regardé du tout ce que fait ton code VBA mais je pense tout de même que le (vrai) problème c'est que tu fait exécuter à VBA ce qu'il y a de plus long à exécuter sur Excel.

A mon avis la dernière remarque "calcul en fin de traitement" devrait faire gagner du temps au code mais de toute façon tu le perd en formule matricielle qui sont de toute façon notoirement lentes...

Donc mon conseil serait si tu veux utiliser VBA, utilise VBA comme du VBA pas comme du Excel, tu verras il y a une très grande différence, et gain de temps énorme et véritable !

En conclusion VBA n'est pas fait pour faire du Excel. VBA est là pour faire ce que Excel ne sait pas faire !

Rechercher des sujets similaires à "code vba ralentissant macro"