[XL-2010] Calcul plus long si lancé en fin de macro

Bonjour,

Je ne comprends pas pourquoi mes Vlookup (255 max) prennent autant de temps dans ma macro, quand je teste juste l'insertion des formules j'en ai pour quelques secondes, quand je le fait vers la fin de la macro c'est plusieurs minutes ... (voire même plantage)
J'ai essayé de mettre le calcul en manuel, pas de changement, de copier les colonnes par valeurs dès qu'elles étaient remplies, idem
Si quelqu'un a une idée pour résoudre ou contourner mon problème je suis preneur.

juste les vlookup:

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
With ThisWorkbook.Sheets("data")
Workbooks.Open Filename:=Range("data_mprec")
dl = .Range("A" & Rows.Count).End(xlUp).Row
.Range("O1") = "pena_MSprecdt"
.Range("P1") = "pena2_MSprecdt"
.Range("Q1") = "dec_MSprecdt"
.Range("O2:O" & dl).FormulaR1C1 = "=IFERROR(VLOOKUP(RC[-14],pena.xlsx!C1:C39,36,0),0)"
.Range("P2:P" & dl).FormulaR1C1 = "=iferror(VLOOKUP(RC[-15],pena.xlsx!C1:C39,35,0),0)"
.Range("Q2:Q" & dl).FormulaR1C1 = "=iferror(VLOOKUP(RC[-16],pena.xlsx!C1:C39,16,0),0)"
.Range("O2:Q" & dl).Copy
.Range("O2:Q" & dl).PasteSpecial xlValues
Application.CutCopyMode = False
Workbooks("pena.xlsx").Close False
end with

Avec le reste:

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
With ThisWorkbook.Sheets("data")
.Cells.ClearContents
Workbooks.Open Filename:=Range("data")
Workbooks("pena.xlsx").Sheets("pena").Range("A1").CurrentRegion.AdvancedFilter _
         Action:=xlFilterCopy, _
         CriteriaRange:=ThisWorkbook.Sheets("TO DO").Range("police_num"), _
         CopyToRange:=.Range("A1"), _
         Unique:=False
Workbooks("pena.xlsx").Close False
dl = .Range("A" & Rows.Count).End(xlUp).Row
.Range("O1").FormulaR1C1 = "aléa"
.Range("O2:O" & dl).FormulaR1C1 = "=RAND()"
.Columns("O").Copy
.Columns("O").PasteSpecial xlValues
Application.CutCopyMode = False
 
 
    .Sort.SortFields.Clear
    .Sort.SortFields.Add Key:=Range("C2:C" & dl), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    .Sort.SortFields.Add Key:=Range("O2:O" & dl), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    .Sort.SetRange Range("A1:O" & dl)
    .Sort.Header = xlYes
    .Sort.MatchCase = False
    .Sort.Orientation = xlTopToBottom
    .Sort.SortMethod = xlPinYin
    .Sort.Apply
 
.Columns("O").ClearContents
c = 0
deb = dl
For i = dl To 2 Step -1
    If .Cells(i, 2) = .Cells(i - 1, 2) Then
        c = c + 1
    Else
        If c >= 5 Then
            .Range(.Cells(deb, 1), .Cells(i + 5, 1)).EntireRow.Delete
            deb = i - 1
            c = 0
        Else
            deb = i - 1
            c = 0
        End If
    End If
Next i
Workbooks.Open Filename:=Range("data_mprec")
.Range("O1") = "pena_MSprecdt"
.Range("P1") = "pena2_MSprecdt"
.Range("Q1") = "dec_MSprecdt"
.Range("O2:O" & dl).FormulaR1C1 = "=IFERROR(VLOOKUP(RC[-14],pena.xlsx!C1:C39,36,0),0)"
.Range("P2:P" & dl).FormulaR1C1 = "=iferror(VLOOKUP(RC[-15],pena.xlsx!C1:C39,35,0),0)"
.Range("Q2:Q" & dl).FormulaR1C1 = "=iferror(VLOOKUP(RC[-16],pena.xlsx!C1:C39,16,0),0)"
.Range("O2:Q" & dl).Copy
.Range("O2:Q" & dl).PasteSpecial xlValues
Application.CutCopyMode = False
Workbooks("pena.xlsx").Close False

Merci d'avance