Optimisation code VBA

Bonjour,

J'ai un soucis avec une macro qui prend énormément de temps. Le Fichier Excel est plutôt lourd et c'est pour cela que j'évite au maximum de rafraîchir les feuilles Excel. Pouvez-vous m'aider à diminuer le temps d’exécution?

Merci

Sub Solva_module()
On Error GoTo RecoverFromError
Application.Calculation = xlManual
Application.EnableEvents = False
Application.ScreenUpdating = False
oldStatusBar = Application.DisplayStatusBar
Application.DisplayStatusBar = True

Dim Nb_Contrats As Single
Dim Pol_Term_Y As Single
Dim Nb_Chocs As Single

Dim Be_gross() As Double
Dim BE_Net() As Double
Dim BE_TG() As Double
Dim BE_TG_No_PB() As Double
Dim BE_UC() As Double
Dim BE_UC_No_PB() As Double
Dim BE_Exp() As Double

Dim Prem_Prev As Double
Dim Prem_TG As Double
Dim Prem_UC As Double
'Dim PU As Double
Prem_Prev = 0
Prem_TG = 0
Prem_UC = 0
'PU = 0

Dim NBV As Double
NBV = 0

Dim CSR_Evol(45) As Double
Dim Res_Prev_LU_GAAP(45) As Double
Dim Res_TG_LU_GAAP(45) As Double
Dim Res_UC_LU_GAAP(45) As Double
Dim Prem_Evol(45) As Double

Dim SheetName As String

Dim CF_Evol(50) As Double

Nb_Contrats = Sheets("Param_Solva_II").Cells(6, 3).Value
Nb_Runs = 19
sheet_Name = Sheets("Param_Solva_II").Cells(2, 3).Value '& "-" & Cells(4, 3).Value

Sheets("Constitutif_Survie").Range("R3:zz567").ClearContents
Sheets("Constitutif_RTO").Range("R3:zz567").ClearContents

Sheets(sheet_Name).Range("BA2:FH1000").ClearContents
Sheets(sheet_Name).Range("FJ3:FQ1000").ClearContents
Sheets(sheet_Name).Range("FS3:FZ1000").ClearContents
Sheets(sheet_Name).Range("GB2:GL1000").ClearContents
Sheets(sheet_Name).Range("GN3:GX1000").ClearContents
Sheets(sheet_Name).Range("GZ3:IQ1000").ClearContents

ReDim Be_gross(Nb_Contrats, Nb_Runs)
ReDim BE_Net(Nb_Contrats, Nb_Runs)
ReDim BE_TG(Nb_Contrats, Nb_Runs)
ReDim BE_TG_No_PB(Nb_Contrats, Nb_Runs)
ReDim BE_UC(Nb_Contrats, Nb_Runs)
ReDim BE_UC_No_PB(Nb_Contrats, Nb_Runs)
ReDim BE_Exp(Nb_Contrats, 4)

For j = 1 To Nb_Runs
Application.StatusBar = "Veuillez patienter traitement en cours [" & Format(j / Nb_Runs, "00.0%") & "]"

    For choc = 1 To Nb_Runs
        If choc = j Then
            Sheets("Param_Solva_II").Cells(8 + choc, 3).Value = "Oui"
        Else
            Sheets("Param_Solva_II").Cells(8 + choc, 3).Value = "Non"
        End If
    Next

    For i = 1 To Nb_Contrats

        Sheets("Calcul").Cells(22, 3).Value = i
        Sheets("Calcul").Cells(5, 2).Value = "Oui"
        Calculate
        Pol_Term_Y = Sheets("Calcul").Cells(36, 3).Value
       '

        Be_gross(i, j) = Sheets("Calcul").Cells(13, 3).Value
        BE_Net(i, j) = Sheets("Calcul").Cells(15, 3).Value
        BE_TG(i, j) = Sheets("Calcul").Cells(16, 3).Value
        BE_UC(i, j) = Sheets("Calcul").Cells(17, 3).Value
        If j = 1 Or j = 2 Or j = 3 Then
           BE_Exp(i, j) = Sheets("Calcul").Cells(18, 3).Value
        Else
           If j = 19 Then
              BE_Exp(i, 4) = Sheets("Calcul").Cells(18, 3).Value
           End If
        End If

        Sheets("Calcul").Cells(5, 2).Value = "Non"
        Calculate
        BE_TG_No_PB(i, j) = Sheets("Calcul").Cells(16, 3).Value
        BE_UC_No_PB(i, j) = Sheets("Calcul").Cells(17, 3).Value

        Sheets("Calcul").Cells(5, 2).Value = "Oui"
        Calculate

        If j = 1 Then

            Prem_Prev = Prem_Prev + WorksheetFunction.Sum(Range("IE3:IE14").Value)
            Prem_TG = Prem_TG + WorksheetFunction.Sum(Range("IV3:IV14").Value)
            Prem_UC = Prem_UC + WorksheetFunction.Sum(Range("JC3:JC14").Value)
'            PU = PU + Sheets("Calcul").Cells(71, 3).Value
            NBV = NBV + Sheets("Calcul").Cells(9, 3).Value

            For t = 1 To Pol_Term_Y + 1
                CSR_Evol(t) = CSR_Evol(t) + Sheets("Calcul").Cells(3 + (t - 1) * 12, 289).Value + Sheets("Calcul").Cells(3 + (t - 1) * 12, 290).Value
                Res_Prev_LU_GAAP(t) = Res_Prev_LU_GAAP(t) + Sheets("Calcul").Cells(3 + (t - 1) * 12, 295).Value
                Res_TG_LU_GAAP(t) = Res_TG_LU_GAAP(t) + Sheets("Calcul").Cells(3 + (t - 1) * 12, 296).Value
                Res_UC_LU_GAAP(t) = Res_UC_LU_GAAP(t) + Sheets("Calcul").Cells(3 + (t - 1) * 12, 297).Value
                  For cf_count = 0 To 11
'                   CF_Evol(t) = CF_Evol(t) + Sheets("Calcul").Cells(3 + (t - 1) * 12 + cf_count, 112).Value
                    Prem_Evol(t) = Prem_Evol(t) + Sheets("Calcul").Cells(3 + (t - 1) * 12 + cf_count, 239).Value + Sheets("Calcul").Cells(3 + (t - 1) * 12 + cf_count, 256).Value + Sheets("Calcul").Cells(3 + (t - 1) * 12 + cf_count, 263).Value
                    Next
            Next

        End If

    Next
Next

For i = 1 To Nb_Contrats
    Sheets(sheet_Name).Cells(1 + i, 53).Value = Be_gross(i, 1)
    Sheets(sheet_Name).Cells(1 + i, 54).Value = BE_Net(i, 1)
    Sheets(sheet_Name).Cells(1 + i, 55).Value = BE_TG(i, 1)
    Sheets(sheet_Name).Cells(1 + i, 56).Value = BE_UC(i, 1)
    Sheets(sheet_Name).Cells(1 + i, 57).Value = BE_TG_No_PB(i, 1)
    Sheets(sheet_Name).Cells(1 + i, 58).Value = BE_UC_No_PB(i, 1)
    Sheets(sheet_Name).Cells(1 + i, 59).Value = BE_Exp(i, 1)
    Sheets(sheet_Name).Cells(1 + i, 162).Value = BE_Exp(i, 2)
    Sheets(sheet_Name).Cells(1 + i, 163).Value = BE_Exp(i, 3)
    Sheets(sheet_Name).Cells(1 + i, 164).Value = BE_Exp(i, 4)
Next

For j = 2 To WorksheetFunction.Min(18, Nb_Runs)
    For i = 1 To Nb_Contrats
        Sheets(sheet_Name).Cells(1 + i, 60 + (j - 2) * 6).Value = Be_gross(i, j)
        Sheets(sheet_Name).Cells(1 + i, 61 + (j - 2) * 6).Value = BE_Net(i, j)
        Sheets(sheet_Name).Cells(1 + i, 62 + (j - 2) * 6).Value = BE_TG(i, j)
        Sheets(sheet_Name).Cells(1 + i, 63 + (j - 2) * 6).Value = BE_UC(i, j)
        Sheets(sheet_Name).Cells(1 + i, 64 + (j - 2) * 6).Value = BE_TG_No_PB(i, j)
        Sheets(sheet_Name).Cells(1 + i, 65 + (j - 2) * 6).Value = BE_UC_No_PB(i, j)
    Next
Next

Worksheets(sheet_Name).Range("FJ2:FQ2").Copy Destination:=Worksheets(sheet_Name).Range("FJ2:FQ" & Nb_Contrats + 1)
Worksheets(sheet_Name).Range("Fs2:Fz2").Copy Destination:=Worksheets(sheet_Name).Range("Fs2:Fz" & Nb_Contrats + 1)
Worksheets(sheet_Name).Range("gz2:iq2").Copy Destination:=Worksheets(sheet_Name).Range("gz2:iq" & Nb_Contrats + 1)

For t = 1 To 45
    Sheets(sheet_Name).Cells(1 + t, 184).Value = CSR_Evol(t)
    Sheets(sheet_Name).Cells(1 + t, 186).Value = Res_Prev_LU_GAAP(t)
    Sheets(sheet_Name).Cells(1 + t, 187).Value = Res_TG_LU_GAAP(t)
    Sheets(sheet_Name).Cells(1 + t, 188).Value = Res_UC_LU_GAAP(t)
    Sheets(sheet_Name).Cells(1 + t, 192).Value = Prem_Evol(t)
Next

Sheets(sheet_Name).Range("GG2").Value = Prem_Prev
Sheets(sheet_Name).Range("GH2").Value = Prem_TG
Sheets(sheet_Name).Range("GI2").Value = Prem_UC
Sheets(sheet_Name).Range("GK2").Value = NBV

'Réinitialisation calcul Best Estimate

Sheets("Param_Solva_II").Cells(9, 3).Value = "Oui"
For j = 2 To Nb_Runs
    Sheets("Param_Solva_II").Cells(9 + j - 1, 3).Value = "Non"
Next j

RecoverFromError:

If Err <> 0 Then

  MsgBox "Error " & Err.Number & ": " & Err.Description, vbOKOnly, "Error Encountered"

  Err.Clear

End If

On Error GoTo 0 ' clears error trapping
Application.StatusBar = False
Application.DisplayStatusBar = oldStatusBar
Application.EnableEvents = True ' reset this
Application.DisplayAlerts = True ' if needed
Application.Calculation = xlAutomatic
Application.ScreenUpdating = True
Application.StatusBar = False
End Sub

Bonjour,

Commente le

Calculate 

et reteste.

Merci pour la réponse j'ai en effet tester avant de voir la réponse et le problème vient bien de là...

Il va falloir que je calculate uniquement les colonnes nécessaires à chaque fois, pas d'autre choix!

Merci beaucoup!

Rechercher des sujets similaires à "optimisation code vba"