Diminution temps d'éxecution

Bonjour, je suis un peu un noob sur VBA, j'ai fait une macron mais son temps d'éxécution est vraiment gigantesque. De nombreuses minutes...

Je me demandais si quelqu'un pouvait m'aider ! Malheureusement je ne peux fournir aucun excel sur lesquels ma macro repose pour des questions professionnelles :/

Option Explicit

Sub ouvrirtest()
    Application.EnableEvents = False
    'Application.Calculation = xlCalculateManual
    Dim wbsrc As Excel.Workbook ' déclarer le fichier source
    Dim wbtrg As Excel.Workbook ' déclarer le fichier detinataire
    Dim ws As Excel.Worksheet   ' declarer les feuil
    Dim shfeuil As Worksheet
    Dim nbLignesChange, nbLignesData, nbLignes As Integer
    Dim strFileName As String
    Dim VariantNumber, VariantChange, VariantData As Variant
    Dim intChoice, i, j  As Integer   'Déclarer les variables de base
    Application.ScreenUpdating = False
    Application.Cursor = xlWait
    nbLignesChange = ThisWorkbook.Worksheets("Position de change conso").Range("B4").End(xlDown).Row - 1
    nbLignesData = ThisWorkbook.Worksheets("Data").Range("AI3").End(xlDown).Row - 1

      Application.DisplayAlerts = False
    While Sheets.Count > 2
      Sheets(3).Delete 'Efface la 1ère feuille
    Wend
    Application.DisplayAlerts = True
    VariantChange = ThisWorkbook.Worksheets("Position de change conso").Range("A1:BG" & nbLignesChange)
    VariantData = ThisWorkbook.Worksheets("Data").Range("A1:BG" & nbLignesData)

    For i = 1 To 11
    Set shfeuil = Sheets.Add(After:=Sheets(Sheets.Count))
        shfeuil.Name = "Feuil" & i
        Application.FileDialog(msoFileDialogOpen).AllowMultiSelect = True
         intChoice = Application.FileDialog(msoFileDialogOpen).Show
            If intChoice <> 0 Then
                strFileName = Application.FileDialog(msoFileDialogOpen).SelectedItems(1)
                Workbooks.Open strFileName
                Set wbsrc = Workbooks.Open(strFileName)
            Else
    MsgBox "La procédure est annulée car aucun fichier n’a été entré."
            End If
    'Set wbsrc = Application.Workbooks.Open("C:\Users\tabello\Mes documents locaux\outil compta-risk\F_Comparaison\COMPARISON_1505.xlsx") ' ouvrir le fichier source
    Set wbtrg = ThisWorkbook ' dire que c'est sur ce fichier que je travail

    'Set ws = wbsrc.Worksheets(1) ' lancer le filtre sur la colonne 4
    'ws.Range("A1:BG4000").AutoFilter Field:=39, Criteria1:="T1", Criteria2:="0LIA01", Criteria3:="<>S9999", Criteria4:="<>S9998", Criteria5:="<>S9997", Criteria6:="<>S9996", Criteria7:="<> S0001"
    Set ws = wbsrc.Worksheets(1)
    If i = 1 Then
      ws.Range("A1:BG30000").AutoFilter Field:=38, Criteria1:="T1"
     ws.Range("A1:BG30000").AutoFilter Field:=20, Criteria1:="0LIA01"
     ws.Range("A1:BG30000").AutoFilter Field:=39, Criteria1:="<> S9998", Operator:=xlAnd, Criteria2:="<> S0001"
    ElseIf i = 6 Then
    Set ws = wbsrc.Worksheets("EMPDEVISE")
    ElseIf i = 7 Then
    Set ws = wbsrc.Worksheets("SUCC EUR")
    ElseIf i = 11 Then
    Set ws = wbsrc.Worksheets("base RPT000081")
    End If
    nbLignes = ws.Range("A1").End(xlDown).Row - 1
    'VariantNumber = ws.Range("A1:BG" & nbLignes)
   ' copie le résultat du filtre
   'nbLignes = ws.Range("A2").End(xlDown).Row
   'nbColonnes = ws.Range("A2").End(xlToRight).Column
       'ws.Cells(Cells(1, 1), Cells(nbLignes, nbColonnes)).Copy
    ws.Range("A1:BG30000").Copy
    Set ws = wbtrg.Worksheets("Feuil" & i)  ' coller le resultat dans la feuil source du fichier destinataire

    'Call donnees(VariantNumber, i,
    ws.Range("A1").PasteSpecial xlPasteAll
    ws.Columns("A:T").ColumnWidth = 15
    ws.Rows("1:1").RowHeight = 70
    ws.Rows("2:100").RowHeight = 15
    Set ws = Nothing
    Application.DisplayAlerts = False
    wbsrc.Close savechanges:=False  ' fermer le fichier source
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    Set wbsrc = Nothing
    Set wbtrg = Nothing
    Application.Cursor = xlDefault
    'ActiveWorkbook.Sheets("PAGE d'ACCUEIL").Activate
    'Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True

Next i

         'ThisWorkbook.Worksheets(1).Range("A1:BG5000").AutoFilter Field:=5, Criteria1:="<>S0001" ', Operator:=xlAnd, Criteria2:="<>S9999"  'Field:=5Criteria3:="<> S9998", Criteria4:="<>S9997", Criteria5:="<> S9996", Operator:=xlAnd, Field:=20, Criteria1:="0LIA01", Operator:=xlAnd, Field:=38, Criteria1:="T1"
    'ThisWorkbook.Worksheets(1).Range("A1:BG5000").AutoFilter Field:=5, Criteria1:="<> S9998" ', Operator:=xlAnd, Criteria2:="<>S9997"
    'ThisWorkbook.Worksheets(1).Range("A1:BG5000").AutoFilter Field:=5, Criteria1:="<> S9996"

    'ThisWorkbook.Worksheets("Feuil1").Range("A1:BG5000").AutoFilter Field:=39, Criteria1:="<>S9999", Operator:=xlAnd, Criteria2:="<>S0001"                       'Array("S0001", "S9999", "S9998", "S9997", "S9996"), Operator:=xlFilterValues
      'ThisWorkbook.Worksheets("Feuil1").Range("A1:BG5000").AutoFilter Field:=20, Criteria1:="0LIA01"
      '  ThisWorkbook.Worksheets("Feuil1").Range("A1:BG5000").AutoFilter Field:=38, Criteria1:="T1"
         MsgBox "Import terminé"

End Sub

Sub donnees()
Dim i, j, d, nbLignesF, nbLignesFX, nbLignesD, nbLignesS, nbLignesP, nbLignesA, nbLignesCP, nbColonnes, nbLignesFC2, nbLignesFundingCurrency1, nbLignesCours, nbLignesEquity, nbLignesEquity2, NumberSelectFC2 As Integer
Dim wb, wb1 As Workbook
Dim x As Double
Dim MaDate As Date
Dim RangeNom As Range
Dim RangeFC2, VarFX, VariantScope, VariantNumber, VariantF, VariantD, VariantD2, VariantFX, VariantCours, VariantFC2, VariantFC1, VariantA, VariantCP, VariantP, VariantEquity, VariantEquity2   As Variant
'Dim appXI As Excel.Application
Dim wsF, wsD, wsD2, wsS, wsA, wsCP, wsFundingCurrency1, wsFundingCurrency2, wsFX, wsP, wsCours, wsEquity, wsEquity2 As Worksheet
Dim filetoOpen As String
Dim debut As Date, temps As Date, fin As Date

Set wb = ThisWorkbook
Set wsF = wb.Worksheets("Feuil1")
Set wsD = wb.Worksheets(1)
Set wsD2 = wb.Worksheets(2)
Set wsS = wb.Worksheets("Feuil3")
Set wsA = wb.Worksheets("Feuil4")
Set wsCP = wb.Worksheets("Feuil5")
Set wsFundingCurrency1 = wb.Worksheets("Feuil6")
Set wsFundingCurrency2 = wb.Worksheets("Feuil7")
Set wsP = wb.Worksheets("Feuil2")
Set wsFX = wb.Worksheets("Feuil8")
Set wsCours = wb.Worksheets("Feuil9")
Set wsEquity = wb.Worksheets("Feuil10")
Set wsEquity2 = wb.Worksheets("Feuil11")

nbLignesCours = wsCours.Range("A3").End(xlDown).Row - 3
nbLignesFX = wsFX.Range("B8").End(xlDown).Row - 7
nbLignesF = wsF.Range("A2").End(xlDown).Row - 1
nbLignesD = wsD.Range("A5").End(xlDown).Row - 4
nbLignesS = wsS.Range("A2").End(xlDown).Row - 1
nbLignesA = wsA.Range("B2").End(xlDown).Row - 1
nbLignesCP = wsCP.Range("A6").End(xlDown).Row - 1
'nbLignesFC2 = wsFundingCurrency2.Application.WorksheetFunction.CountA(Columns(3)) + 10
nbLignesFC2 = 5000
nbLignesFundingCurrency1 = wsFundingCurrency1.Range("B6").End(xlDown).Row - 5
nbLignesP = wsP.Range("A1").End(xlDown).Row - 3
nbLignesEquity = wsEquity.Range("A1").End(xlDown).Row - 1
nbLignesEquity2 = wsEquity2.Range("A1").End(xlDown).Row - 1

VariantScope = wsS.Range("A1:BG3000")

VariantD = wsD.Range("A1:BG30000")
VariantD2 = wsD2.Range("A1:BG30000")
VariantFX = wsFX.Range("A1:BG30000")
VariantCours = wsCours.Range("A1:BG30000")
VariantFC2 = wsFundingCurrency2.Range("A1:BG30000")
VariantFC1 = wsFundingCurrency1.Range("A1:BG30000")
VariantA = wsA.Range("A1:BG30000")
VariantCP = wsCP.Range("A1:BG30000")
VariantP = wsP.Range("A1:BG30000")
VariantEquity = wsEquity.Range("A1:BG300000")
VariantEquity2 = wsEquity2.Range("A1:BG30000")

    MaDate = InputBox("Entrer une date", Date, "31/03/2018")

debut = Time

On Error Resume Next

    For j = 1 To nbLignesF
   If wsF.Cells(j + 1, 39).Value <> 0 Then
    If WorksheetFunction.VLookup(wsF.Cells(j + 1, 39).Value, VariantScope, 1, False) = 0 Then
        wsF.Rows(j + 1).Delete
            If j > 2 Then
                j = j - 1
            End If
        End If
    Else
    Exit For
    End If
   Next j

VariantF = wsF.Range("A1:BG30000")
'Application.ScreenUpdating = False
   ' Set r = Nothing
    ' On Error Resume Next
   ' For j = 1 To nbLignesF
      '  If WorksheetFunction.VLookup(VariantF(j + 1, 39), VariantScope, 1, False) = 0 Then
    '        If r Is Nothing Then Set r = Cells(j + 1, 1) Else Set r = Union(r, Cells(j + 1, 1))
     '   End If
  '  Next j
   ' r.EntireRow.Delete shift:=xlUp
   ' Application.ScreenUpdating = True

 For i = 1 To nbLignesFC2
    If VariantFC2(i + 32, 3) = "DOTATIONS FINANCEES PAR DEVISES EMPRUNTEES :" Then
           'wsFundingCurrency2.Range("B" & i + 34).Activate
           'wsFundingCurrency2.Range("B87").CurrentRegion.Select

             RangeFC2 = VariantFC2(i + 34, 2).CurrentRegion
                                                                    ' Address(True, True, xlR1C1)
                NumberSelectFC2 = UBound(RangeFC2) - 1
            Exit For
    End If
Next i

For j = 1 To NumberSelectFC2
            If RangeFC2(j, 10) <> "EUR" Then
            VariantD2(j + 2, 50) = RangeFC2(j, 2)
            VariantD2(j + 2, 51) = RangeFC2(j, 10)
            VariantD2(j + 2, 52) = RangeFC2(j, 12) / 1000000
            VariantD2(j + 2, 49) = VariantD2(j + 2, 51) & VariantD2(j + 2, 50)
            ElseIf RangeFC2(j, 10) = "EUR" And RangeFC2(j + 1, 10) <> "EUR" Then
            d = d + 1
            End If
Next j

For i = 1 To nbLignesFX
    VariantD2(i + 2, 3) = VariantFX(i + 7, 4) & VariantFX(i + 7, 2)
    VariantD2(i + 2, 4) = VariantFX(i + 7, 5)
Next i

'For i = 1 To d
'wsD2.Range(Cells(3, 49), Cells(NumberSelectFC2, 51)).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
'Next i
For i = 1 To nbLignesA
    VariantD2(i + 2, 11) = VariantA(i + 1, 2) & VariantA(i + 1, 1)
   VariantD2(i + 2, 12) = VariantA(i + 1, 3)
Next i

For i = 1 To nbLignesP
    VariantD2(i + 1, 32) = VariantP(i + 3, 3)
    VariantD2(i + 1, 33) = VariantP(i + 3, 12)
Next i

For i = 1 To nbLignesS
    VariantD2(i + 2, 35) = VariantScope(i + 2, 1)
    VariantD2(i + 1, 36) = VariantScope(i + 1, 12)
Next i

   For i = 1 To nbLignesCP
        For j = 1 To nbLignesCours
            If wsCP.Cells(i + 5, 8) <> "EUR" And wsCP.Cells(i + 5, 8) = VariantCours(j + 3, 1) Then
                VariantD2(i + 2, 17) = wsCP.Cells(i + 5, 8) & wsCP.Cells(i + 5, 15)
                VariantD2(i + 2, 18) = wsCP.Cells(i + 5, 9) / VariantCours(j + 3, 5)

    ElseIf wsCP.Cells(i + 5, 8) = "EUR" And wsCP.Cells(i + 5, 10) = VariantCours(j + 3, 1) Then
    VariantD2(i + 2, 17) = wsCP.Cells(i + 5, 10) & wsCP.Cells(i + 5, 15)
    VariantD2(i + 2, 18) = wsCP.Cells(i + 5, 11) / VariantCours(j + 3, 5)
    End If

 Next j
Next i

For i = 1 To nbLignesFundingCurrency1
        VariantD2(i + 2, 42) = VariantFC1(i + 5, 1)
        VariantD2(i + 2, 43) = VariantFC1(i + 5, 3)
        VariantD2(i + 2, 44) = VariantFC1(i + 5, 9) / 1000000
        VariantD2(i + 2, 41) = VariantD2(i + 2, 43) & VariantD2(i + 2, 42)
Next i

For i = 1 To nbLignesF
    VariantF(i + 1, 59) = VariantF(i + 1, 29) & VariantF(i + 1, 5)
Next i

VariantNumber = Range("A1:C30000")

nbLignesF = wsF.Range("A2").End(xlDown).Row - 1

For i = 1 To nbLignesD
    x = 0
    For j = 1 To nbLignesF
        If VariantD(i + 4, 1) = VariantF(j + 1, 59) And VariantF(j + 1, 39) <> "S9996" And VariantF(j + 1, 39) <> "S9997" And VariantF(j + 1, 39) <> "S0001" Then 'And WorksheetFunction.VLookup(VariantF(i + 2, 39), VariantNumber, 2) <> "" Then 'And VariantF(i + 2, 59) <> VariantF(i + 1, 59) Then
        VariantD2(i + 2, 24) = VariantF(j + 1, 5)
        VariantD2(i + 2, 25) = VariantF(j + 1, 39)
        VariantD2(i + 2, 26) = VariantF(j + 1, 29)
        VariantD2(i + 2, 23) = VariantF(j + 1, 59)
        'VariantF(j + 1, 33) = Replace(VariantF(j + 1, 33), ".000", "")
          'VariantF(j + 1, 33) = Replace(VariantF(j + 1, 33), ",", "")
        'VariantF(j + 1, 33) = CDbl(VariantF(j + 1, 33))

         x = VariantF(j + 1, 33) + x
        'Else If VariantD(j + 4, 1) = VariantF(i + 1, 59) And VariantF(i + 1, 39) <> "S9998" And VariantF(i + 1, 39) <> "S9996" And VariantF(i + 1, 39) <> "S9997" And VariantF(i +1, 59) = VariantF(i+2,59)
        ElseIf VariantF(j + 1, 39) = "S0001" And VariantF(j + 1, 7) <> "S0001" Then
        VariantD2(i + 2, 24) = VariantF(j + 1, 39)
         VariantD2(i + 2, 24) = VariantF(j + 1, 5)
        VariantD2(i + 2, 25) = VariantF(j + 1, 39)
        VariantD2(i + 2, 26) = VariantF(j + 1, 29)
        VariantD2(i + 2, 23) = VariantF(j + 1, 59)
        'VariantF(j + 1, 33) = Replace(VariantF(j + 1, 33), ",", "")
        'VariantF(j + 1, 33) = Replace(VariantF(j + 1, 33), ".000", "")
        'VariantF(j + 1, 33) = CDbl(VariantF(j + 1, 33))
        x = -VariantF(j + 1, 32)                                                                                                                  'PAS SUR DU TOUT ICI
        End If

    Next j
    VariantD2(i + 2, 28) = x
Next i

fin = Time

temps = fin - debut

MsgBox ("C'est fini !" & Chr(10) & "temps de traitement " & temps)

'PHASE CALCUL
For i = 1 To nbLignesD
x = 0
    For j = 1 To nbLignesFundingCurrency1
    VariantD2(j + 2, 41) = Replace(VariantD2(j + 2, 41), "E1", "")
    If VariantD2(j + 2, 41) = VariantD(i + 4, 1) Then
            wsD.Cells(i + 4, 7) = VariantD2(j + 2, 44)
            wsD.Cells(i + 4, 7).Interior.ColorIndex = 3
    End If
    Next j

    For j = 1 To NumberSelectFC2
        If VariantD2(j + 2, 49) = VariantD(i + 4, 1) Then
            wsD.Cells(i + 4, 8).Value = VariantD2(j + 2, 52)
            wsD.Cells(i + 4, 8).Interior.ColorIndex = 3
        End If
    Next j

    For j = 1 To nbLignesS
        If VariantD2(i + 2, 24) = VariantScope(j + 1, 1) Then
        VariantD2(i + 2, 27) = VariantScope(j + 1, 5)
        End If
    Next j
    For j = 1 To nbLignesA
            If VariantD(i + 4, 1) = VariantD2(j + 2, 11) Then
                wsD.Cells(i + 4, 4).Value = VariantD2(j + 2, 12)
                wsD.Cells(i + 4, 4).Interior.ColorIndex = 3
            'Else
                'VariantD(i + 4, 3) = 0
            End If
    Next j

    For j = 1 To nbLignesFX
        If VariantD(i + 4, 1) = VariantD2(j + 2, 3) Then
        wsD.Cells(i + 4, 3).Value = VariantD2(j + 2, 4)
        End If
    Next j

     For j = 1 To nbLignesCP
        If VariantD(i + 4, 1) = VariantD2(j + 2, 17) Then
                x = VariantD2(j + 2, 18) + x
        End If
    Next j
   wsD.Cells(i + 4, 6).Value = x
   If x <> 0 Then
    wsD.Cells(i + 4, 6).Interior.ColorIndex = 3
    End If
     x = 0
    For j = 1 To nbLignesEquity
        If VariantD(i + 4, 1) = VariantEquity(j + 1, 6) And VariantEquity(j + 1, 1) = MaDate Then
            x = VariantEquity(j + 1, 22) + x
        End If
    wsD.Cells(i + 4, 10).Value = x
    If x <> 0 Then
        wsD.Cells(i + 4, 10).Interior.ColorIndex = 3
    End If
    Next j

    For j = 1 To nbLignesEquity2
        If VariantD(i + 4, 1) = VariantEquity2(j + 1, 6) And VariantEquity2(j + 1, 1) = MaDate Then
            x = VariantEquity2(j + 1, 22) + x
        End If
    wsD.Cells(i + 4, 10).Value = x + wsD.Cells(i + 4, 10).Value
    If x <> 0 Then
        wsD.Cells(i + 4, 10).Interior.ColorIndex = 3
    End If
    Next j

    For j = 1 To nbLignesD
            If VariantD(i + 4, 1) = VariantD2(j + 2, 23) Then
                wsD.Cells(i + 4, 5).Value = VariantD2(j + 2, 27) * VariantD2(j + 2, 28) / 100
                wsD.Cells(i + 4, 5).Interior.ColorIndex = 3
                wsD.Cells(i + 4, 9).Value = VariantD2(j + 2, 27)
                wsD.Cells(i + 4, 9).Interior.ColorIndex = 3
            End If
    Next j

    wsD.Cells(i + 4, 11).Value = wsD.Cells(i + 4, 2).Value + wsD.Cells(i + 4, 3).Value + wsD.Cells(i + 4, 4).Value + wsD.Cells(i + 4, 5).Value + wsD.Cells(i + 4, 6).Value + wsD.Cells(i + 4, 7).Value + wsD.Cells(i + 4, 8).Value + wsD.Cells(i + 4, 10).Value * wsD.Cells(i + 4, 9).Value
    If wsD.Cells(i + 4, 11).Value <> 0 Then
    wsD.Cells(i + 4, 11).Interior.ColorIndex = 3
    End If

Next i
'code

fin = Time

temps = fin - debut

MsgBox ("C'est fini !" & Chr(10) & "temps de traitement " & temps)

'RangeNom = wsD.Range("A5:A" & nbLignesD + 4)
'wsD.range("A& nbLignesD + 17 ":A
wsD.Range("A5:A" & nbLignesD + 4).Copy
wsD.Range("A" & nbLignesD + 17).PasteSpecial xlPasteAll

nbColonnes = wsD.Range("A4").End(xlToRight).Column
wsD.Range(Cells(4, 1), Cells(nbLignesD + 4, nbColonnes)).Select
Selection.Replace what:="", Replacement:=0
Selection.HorizontalAlignment = xlCenter

End Sub

Merci d'avance pour votre aide !

bonjour

solution : supprime tout VBA. Depuis 25 ans, jamais eu besoin !

quel est ton besoin, ton BUT ?

à quoi sert ton fichier ?

joins un exemple court contenant des données bidons

Bonjour jmd,

Tu a écrit :

solution : supprime tout VBA. Depuis 25 ans, jamais eu besoin !

suggestion : et si tu supprimais tous les messages de ce forum qui contiennent du code VBA ?

ajout : tiens, t'as oublié d'promotionner ton attirail TCD - Power Query - Power BI Desktop ?

dhany

En fait toute upload de fichier est bloquée -_-. Donc c'est compliqué de vous faire conceptualiser le schimlblik.

Mais en gros, c'est pour récupérer, voire faire des opérations en fonction de nombreuses conditions.

Rechercher des sujets similaires à "diminution temps execution"