Code VBA et Vlookup, trop longue exécution

Bonjour à tous !

Pourriez vous m'expliquer ( et si possible m'aider) pourquoi ce code, pourtant assez rapide normalement car utilisant VlookUp met plusieurs minutes à se réaliser ? (je précise que cela se fait sur 1000 lignes environ et le variant possédant lui aussi environ 1000 lignes)

Sub donnees()
Dim i, j, d, nbLignesF, nbLignesFX, nbLignesD, nbLignesS, nbLignesP, nbLignesA, nbLignesCP, nbColonnes, nbLignesFC2, nbLignesFundingCurrency1, NumberSelectFC2 As Integer
Dim wb, wb1 As Workbook
Dim x As Double

Dim RangeNom As Range
Dim RangeFC2, VarFX, VariantScope, VariantNumber, VarRetour As Variant
'Dim appXI As Excel.Application
Dim wsF, wsD, wsD2, wsS, wsA, wsCP, wsFundingCurrency1, wsFundingCurrency2, wsFX, wsP As Worksheet
Dim filetoOpen As String
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")

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

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

On Error Resume Next
For i = 1 To nbLignesS
    For j = 1 To nbLignesF

       If WorksheetFunction.VLookup(wsF.Cells(j + 1, 39).Value, VariantScope, 1, False) = 0 Then
        wsF.Rows(j).Delete
        End If
    Next j
Next i

 

(Il y a bien sûr une suite au code mais elle n'est pas important car j'azi stoppé l'exécution à la fin de cette boucle et cela met quand même de nombreuses minutes)

Merci d'avance pour votre aide !

bonjour,

la boucle i est inutile selon moi, tu peux enlever ces instructions

For i = 1 To nbLignesS

Next i

En effet, je ne sais même pas pourquoi j'ai mis ce i.

Mais néanmoins, même sans cette boucle inutile ca met toujours un certain temps à se faire étrangement !

re-bonjour,

une autre proposition

On Error Resume Next
    Application.ScreenUpdating = False
    For j = nbLignesF to 1 step -1

       If WorksheetFunction.VLookup(wsF.Cells(j + 1, 39).Value, VariantScope, 1, False) = 0 Then
        wsF.Rows(j).Delete
        End If
    Next j
    Application.ScreenUpdating = True

Non malheureusement la procédure est toujours aussi longue...

Je pensais que ce serait rapide avec Vlookup !

Bonjour,

le problème de performance vient très probablement du rows.delete

essaie ceci

    Application.ScreenUpdating = False
    Set r = Nothing
    For j = 1 To nbLignesF
        If WorksheetFunction.VLookup(wsF.Cells(j + 1, 39).Value, VariantScope, 1, False) = 0 Then
            If r Is Nothing Then Set r = Cells(j, 1) Else Set r = Union(r, Cells(j, 1))
        End If
    Next j
    r.EntireRow.Delete shift:=xlUp
    Application.ScreenUpdating = True

Hum ca dure quasiment autant de temps, à peu près 30 secondes :/

Bonsoir,

excusez moi de m'incruster...

Auriez vous le fichier qui va avec les lignes de codes ?

@ bientôt

LouReeD

Le problème étant que je ne peux pas l'envoyer car il y a des données sensibles dessus

Avez vous des MFC sur votre (vos) feuille(s) ?

Car s'il y en a beaucoup, cela ralenti le déroulement des macros... Je crois...

@ bientôt

LouReeD

Qu'est ce donc qu'une MFC ?

Mise en Forme Conditionnelle : les cellules se mettent "en forme" en fonction de conditions, et s'il y en a beaucoup, surtout avec des codes d'ajout et de suppression de ligne, cela ralenti énormément les codes, car Excel doit redéfinir les MFC suite aux suppressions ou ajouts...

@ bientôt

LouReeD

Bonjour,

si la piste des MFC ne donne rien et que la proposition de h2so4 n'améliore je te conseille ceci :

• te créer une variable tableau du nombre de ligne titre.
• 1 pour les lignes à supprimer
• à la fin coller cette variable dans une colonne supp
• trier dessus avant de supprimer. Elles ne seront plus dispersées sur la feuille et ça sera plus rapide

Bonsoir,

y a t il des calculs dans vos feuilles ?

Car à chaque suppression il y a re calcul... Pour peu que ce soit des SOMMEPROD "à gogo" cela peut ralentir le code...

un :

Application.Calculation = xlCalculationManual

en début de sub

puis un

Application.Calculation =xlCalculationAutomatic

en fin de sub peu peut-être accélérer les choses, mais sans fichier...

Avez vous essayer de copier coller toutes les cellules de chaque feuille dans un nouveau classeur et de lancer la macro sur celui-ci ?

@ bientôt

LouReeD

Alors, il n'y a aucun calcul sur la feuille sur laquelle sont supprimées les lignes, ce sont juste des données.

Par contre, la piste du Variant me semble prometteuse, cela permettra surement de supprimer le surplus de temps j'imagine.

Le Rows(j).Delete marche aussi sur les variants ?

Il y a pas mal de problèmes de formats de cellules aussi c'est vrai, mais le formatage que je fais arrive après ce code normalement, donc il n'est pas impliqué je pense !

Bonjour,

alors cette optimisation ? Cela va plus vite ?

@ bientôt

LouReeD

Ah désolé j'étais en long week-end donc je n'ai pas pu tester ! Mais cela semble ne pas avoir régler le problème.

Voilà ce que je vais faire : je vais mettre tout mon code qui, je pense est assez peu optimisé et met vraiment pas mal de minutes. J'imagine qu'un vrai codeur VBA peut l'efficienter véritablement mais moi j'ai atteint les limites de mes capacités ahahaha

Y a des notes et des lignes en vert de temps en temps car je les garde sous la main pour essayer certaines choses !

C'est pour voir le contexte plus global

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 9
    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 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")
    End If
    nbLignes = ws.Range("A1").End(xlDown).Row - 1
    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

    Application.EnableEvents = True

Next i

         MsgBox "Import terminé"

End Sub

Sub donnees()
Dim i, j, d, nbLignesF, nbLignesFX, nbLignesD, nbLignesS, nbLignesP, nbLignesA, nbLignesCP, nbColonnes, nbLignesFC2, nbLignesFundingCurrency1, nbLignesCours, NumberSelectFC2 As Integer
Dim wb, wb1 As Workbook
Dim x As Double

Dim RangeNom As Range
Dim RangeFC2, VarFX, VariantScope, VariantNumber, VariantF, VariantD, VariantD2, VariantFX, VariantCours, VariantFC2, VariantFC1, VariantA, VariantCP, VariantP As Variant
'Dim appXI As Excel.Application
Dim wsF, wsD, wsD2, wsS, wsA, wsCP, wsFundingCurrency1, wsFundingCurrency2, wsFX, wsP, wsCours As Worksheet
Dim filetoOpen As String
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")

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

VariantScope = wsS.Range("A1:BG3000")
VariantF = wsF.Range("A1:BG30000")
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")

i = 3

On Error Resume Next

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

'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

        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)
        End If

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

'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

    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, 10).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, 9).Value
    If wsD.Cells(i + 4, 10).Value <> 0 Then
    wsD.Cells(i + 4, 10).Interior.ColorIndex = 3
    End If
Next i

'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

Bonjour,

un détail en passant.

Pourquoi .AllowMultiSelect = True alors que tu n'ouvres que le 1er : strFileName = Application.FileDialog(msoFileDialogOpen).SelectedItems(1) ?

eric

En effet ! C'était le vestige d'un ancien code qui n'a plus lieu d'être !