Bonjour à toutes et tous,

J'ai un code qui fonctionne mais qui a un problème d'optimisation car cela prend beaucoup trop de temps environ 7 minutes. Je sais où se situe le problème puisque c'est lorsqu'il effectue la boucle sur environ 1700 lignes permettant de copier des données d'un classeur sur un autre classeur. Malheureusement pour des raisons de protections des données, je ne peux mettre les fichiers utilisés en annexe donc j'espère que vous pourrez m'aguiller sur comment améliorer cette partie de code (nul doute que plein d'autres choses pourraient être améliorées mais puisqu'il fonctionne ).

Peut-être avec l'utilisation de tableaux mais j'ai un peu de peine avec leurs compréhensions .

Code : Sélectionner tout - Visualiser dans une fenêtre à part
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
Sub A_Optimiser()
 
'On définit les variables
Set FS = ActiveWorkbook
Set SS0 = FS.Worksheets("donnees suivi DE")
 
LastRowSS = SS0.Range("A" & Rows.Count).End(xlUp).Row
 
 
'On met en ordre les colonnes selon les désirs de BPO
    Columns("C:C").Cut
    Columns("B:B").Insert Shift:=xlToRight
    Columns("D:D").Cut
    Columns("C:C").Insert Shift:=xlToRight
    Columns("M:M").Cut
    Columns("D:D").Insert Shift:=xlToRight
    Columns("H:H").Cut
    Columns("G:G").Insert Shift:=xlToRight
    Columns("M:M").Cut
    Columns("F:F").Insert Shift:=xlToRight
 
'On insert 2 colonnes
    Range("H1").Resize(, 2).EntireColumn.Insert Shift:=xlToRight
 
 
'Ouvrir le fichier "Rapport_"
    Workbooks.Open "G:\test\retest\5.     \Rapport_.xlsx", WriteResPassword:="XXXX", IgnoreReadOnlyRecommended:=True
 
'Fige l'écran pendant la suppression des lignes
    Application.ScreenUpdating = False
 
'Désactiver les alertes pour empêcher l'affichage ' des messages du genre "Voulez-vous etc."
    Application.DisplayAlerts = False
 
'On définit les variables
Set FD = ActiveWorkbook
Set SD0 = FD.Worksheets("donnees ") 'Pour les colonnes E et F
Set SD1 = FD.Worksheets("Placement") 'Pour la colonne AH
Set SD2 = FD.Worksheets("dernier entretien")
Set SD3 = FD.Worksheets("DE_actifs")
 
'On efface l'onglet "TEST dernier entr." s'il existe
    If FExist("TEST dernier entr.") Then
        FD.Worksheets("TEST dernier entr.").Delete
    Else
 
    End If
C'EST SUR CETTE PARTIE QUE CELA BUG

Code : Sélectionner tout - Visualiser dans une fenêtre à part
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
'Pour chaque ID on copie les valeurs de la "Situation initiale - Saisi le"
'et "l'employabilité" de l'onglet "donnees"
    For i = 2 To LastRowSS
        NDE = SS0.Cells(i, 3).Value
        j = SD0.Range("C:C").Find(What:=NDE, LookAt:=xlWhole).Row
        g = SD1.Range("E:E").Find(What:=NDE, LookAt:=xlWhole).Row
 
        SD0.Activate
        Cells(j, 6).Copy
        SS0.Activate
        SS0.Cells(i, 9).Select
         ActiveCell.PasteSpecial Paste:=xlPasteValues
 
'Pour chaque DE on copie les valeurs de la "Situation professionnelle"
'de l'onglet "Placement"
        SD1.Cells(g, 34).Copy
        SS0.Cells(i, 8).Select
        ActiveCell.PasteSpecial Paste:=xlPasteValues
        Set j = Nothing
        Set g = Nothing
    Next i
A PARTIR DE LA CELA FONCTIONNE A NOUVEAU

Code : Sélectionner tout - Visualiser dans une fenêtre à part
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
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
'On met les titres de colonnes
    SD0.Cells(1, 6).Copy SS0.Cells(1, 9)
    SD1.Cells(1, 34).Copy SS0.Cells(1, 8)
 
'On met en forme les titres de colonnes
    SS0.Activate
    Range("A1:O1").Select
    With Selection
        .VerticalAlignment = xlBottom
        .WrapText = True
        .orientation = 90
        .AddIndent = False
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
 
'On adapte la largueur des colonnes
    Cells.EntireColumn.AutoFit
 
'On effacer le fond des cellules et on met une ligne sur 2 en grisé
    Range(Cells(1, 1), Cells(LastRowSS, 15)).Select
    Selection.Interior.ColorIndex = xlColorIndexNone
        Selection.FormatConditions.Add Type:=xlExpression, Formula1:= _
        "=MOD(LIGNE();2)"
        Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
            With Selection.FormatConditions(1).Interior
                .PatternColorIndex = xlAutomatic
                .ThemeColor = xlThemeColorDark1
                .TintAndShade = -0.249946592608417
            End With
        Selection.FormatConditions(1).StopIfTrue = False
        Selection.AutoFilter
 
'On trie du plus grand au plus petit les écarts d'entretiens
    SS0.AutoFilter.Sort.SortFields.Clear
    SS0.AutoFilter.Sort.SortFields.Add _
        Key:=Range("D1:D" & LastRowSS), SortOn:=xlSortOnValues, Order:=xlDescending, _
        DataOption:=xlSortNormal
    With SS0.AutoFilter.Sort
        .Header = xlYes
        .MatchCase = False
        .orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
 
    Range(Cells(2, 4), Cells(LastRowSS, 4)).Select
'On met en évidence tout les cellules de la colonne "D" avec une valeur supérieure ou égale à 60
    Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlGreaterEqual _
        , Formula1:="=60"
    Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
    With Selection.FormatConditions(1).Font
        .Bold = True
        .italic = False
        .Color = -16776961
        .TintAndShade = 0
    End With
    With Selection.FormatConditions(1).Interior
        .PatternColorIndex = xlAutomatic
        .Color = 11515107
        .TintAndShade = 0
    End With
    Selection.FormatConditions(1).StopIfTrue = False
 
'On met en évidence tout les cellules de la colonne "D" avec une valeur comprise entre 45 et 59
    Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlBetween, _
        Formula1:="=45", Formula2:="=59"
    Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
    With Selection.FormatConditions(1).Font
        .Bold = True
        .italic = False
        .ThemeColor = xlThemeColorAccent2
        .TintAndShade = 0
    End With
    With Selection.FormatConditions(1).Interior
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorAccent4
        .TintAndShade = 0.599963377788629
    End With
    Selection.FormatConditions(1).StopIfTrue = False
 
'On renomme l'onglet
    SS0.Name = "TEST dernier entr."
    SD2.Visible = False
 
'On copie l'onglet sur le fichier "Rapport_"
    SS0.Copy After:=SD2
 
'CETTE PARTIE DU CODE EST UTILISEE POUR LE CONTROLE DES DONNES SYSTEME ET
'REPREND LA MACRO "CONTROLE _SAISIE_SYSTEME"
 
'On active l'onglet "actifs" du fichier "Rapport_"
    SD3.Activate
 
LastRowD3 = SD3.Range("A" & Rows.Count).End(xlUp).Row
 
'On met la colonne R en format Date
    Columns("R:R").TextToColumns Destination:=Range("R1"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
        Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
        :=Array(1, 4), TrailingMinusNumbers:=True
 
'On insère une colonne T
    Columns("T:T").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
 
'On fait la soustraction entre la date d'inscription et la date d'entrée en service
    Range("T2") = "Contrôle de saisie PLASTA"
    Range("T3").FormulaR1C1 = "=RC[-2]-RC[-1]"
    Range("T3").AutoFill Destination:=Range("T3:T" & LastRowD3), Type:=xlFillDefaul
 
'On met la colonne T en format standard
    Columns("T:T").NumberFormat = "General"
 
'On filtre et on trie sur la colonne "Contrôle de saisie SYSTEME" afin de
'trouver les valeurs exceptionnelles signes d'une erreur de saisie.
    Rows("2:2").AutoFilter
    SD3.AutoFilter.Sort.SortFields.Clear
    SD3.AutoFilter.Sort.SortFields.Add _
        Key:=Range("T2"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption _
        :=xlSortNormal
    With SD3.AutoFilter.Sort
        .Header = xlYes
        .MatchCase = False
        .orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
 
'FIN DE LA PARTIE DU CODE UTILISEE POUR LE CONTROLE DES DONNES SYSTEME ET
'REPRENNANT LA MACRO "CONTROLE _SAISIE_SYSTEME"
 
'Défige l'écran pendant la suppression des lignes
    Application.ScreenUpdating = True
 
'Activer les alertes pour empêcher l'affichage ' des messages du genre "Voulez-vous etc."
    Application.DisplayAlerts = True
 
 
'On sauve le fichier "Rapport_" en gardant l'option lecture seule
    FD.SaveAs "G:\test\retest\5.     \Rapport_.xlsx", WriteResPassword:="XXXX", ReadOnlyRecommended:=True
    FD.Close
 
 
    FS.Close Savechanges:=False
 
End Sub