[RESOLU] Optimisation d'un code

[TgR]

Bonjour à tous,

J'aimerais savoir s'il est possible d'optimiser un code. Je m'explique, je travaille sur un tableau que l'on m'a donné et sur lequel j'ai automatisé une tâche répétitive, notamment grâce à l'aide de Robert du forum. Un ami m'a ajouté un bout de code après celui de Robert et là le problème survient. Sur les ordis du boulot, le code met 553 Secondes à être effectué !

J'imagine que le problème vient du fichier en lui même qui pèse près de 18mo et qui contient énormément de formules, et ça je ne peux rien y faire hélas... Les seules options que je possède sont : attendre 11mn que le code s'effectue ou optimiser le code si c'est possible. Je joins le fichier mais celui-ci a été réduit. Voici les éléments que j'ai supprimé pour pouvoir le compresser !

Il ne reste plus que les mois de Janvier et de Février : Normalement les onglets vont de Janvier à Décembre

Le nombre de ligne pour les patients a été réduit. Il s'arrête actuellement a 225 alors qu'il allait jusqu'à 423 auparavant (avec la même mis en forme bien sur). J'imagine que ce qui ralenti considérablement le programme est le nombre de couleurs utilisées et le nombre formidablement élevé de formule, mais comme je l'ai déjà dis, c'est délicat de toucher à ça, la personne étant un peu frileuse à ce qu'on modifie son tableau.

Les codes créés par Robert du forum et mon ami se trouve dans le module 2. A toute personne qui pourra m'aider, merci d'avance !

le code :

Sub macro1()
Dim montab As Variant
Dim ni As Byte
Dim cel As Range, cel2 As Range, cel3 As Range
Dim ad As String, ad2 As String, ad3 As String, ad4 As String
Dim T As Double
Dim i As Integer
Dim nbDayInMonth
Dim nbDayInNextMonth
Application.ScreenUpdating = False

T = Timer
ni = ActiveSheet.Index 'définit le numéro d'index ni

For Each cel In Sheets(ni).Range("H4:H423") 'boucle sur toutes les cellules de la plage H4:H24 de l'onglet actif
    'condition : si la cellule est vide et l'une des cellules en colonne D ou E n'est pas vide
    If cel.Value = "" And cel.Offset(0, -5).Value <> "" Then
        ad = cel.Offset(0, -5).Address 'définit l'adresse de la cellule colonne C
        ad2 = cel.Offset(0, 3).Address 'définit l'adresse de la colonne k
        'copie les colonne C à F de la cellule cel et les colle dans l'onglet suivant au même endroit
        Sheets(ni).Cells(cel.Row, 3).Resize(1, 4).Copy Sheets(ni + 1).Range(ad)
        Sheets(ni).Cells(cel.Row, 39).Copy Sheets(ni + 1).Range(ad2)
    End If 'fin de la condition
Next cel 'prochaine cellule de la boucle

For Each cel2 In Sheets(ni).Range("K4:K423")
    nbDayInMonth = Day(DateSerial(Year(Date), ni + 1, 1) - 1)
    nbDayInNextMonth = Day(DateSerial(Year(Date), ni + 2, 1) - 1)
    If cel2.Offset(0, nbDayInMonth - 1).Value <> "" Then
        ad3 = cel2.Address
        cel2.Offset(0, nbDayInMonth - 1).Copy Sheets(ni + 1).Range(ad3)
        Range((ad3)).Select
        
        ad4 = cel2.Offset(0, nbDayInNextMonth - 1).Address
        i = 1
        For Each cel3 In Sheets(ni + 1).Range(ad3, ad4)
            If cel2.Offset(0, nbDayInMonth - 1).Value <> "P" Then
                cel3 = cel2.Offset(0, nbDayInMonth - 1).Value + i
                i = i + 1
            Else
                cel3 = cel2.Offset(0, nbDayInMonth - 1).Value
            End If
        Next cel3
    End If
Next cel2
MsgBox Application.Round((Timer - T), 1) & " Sec"
End Sub

 

[Pierrot93]

Re : Optimisation d'un code

Bonjour,

essaye peut être ceci :

Application.Calculation = xlCalculationManual
'ton code
Application.Calculation = xlCalculationAutomatic

stoppera les calculs des formules pendant l'exécution...

bonne journée
@+

 

[TgR]

Re : Optimisation d'un code

Bonjour Pierrot93.

Ta solution réduit le temps d'exécution de 553 secondes à ... 1 seconde !!!!! C'est extra ! Merci beaucoup d'avoir répondu si vite !

Je note ton bout de code dans mon calepin de trucs et astuces VBA