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.