Bonjour a toutes et a tous
J'ai un petit module qui me genere un nouvel excel et qui nourrit 3 onglets avec des exports de requetes. Tout fonctionne bien sauf ce que ça demande beaucoup de ressource (j'ai pas une grosse bete mais ca lui demande 2h30 ... ) Je vous propose mon code ci dessous
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 Dim db As DAO.Database, rs As DAO.Recordset Dim i As Integer, j As Integer Dim depart As Double Dim departdate As String Dim sEmplacementInitial As String, sEmplacementFinal As String ' Mémoriser l'instant de démarrage pour mesurer la durée du traitement depart = Now() departdate = Format(depart, "dd-mm-yyyy") 'Cree une copie de extraction CHSCT sEmplacementInitial = CurrentProject.Path & "\Extraction SMPR.xlsx" sEmplacementFinal = CurrentProject.Path & "\Extractions\Extraction CHSCT.xlsx" ' Copie du fichier FileCopy sEmplacementInitial, sEmplacementFinal Name sEmplacementFinal As CurrentProject.Path & "\Extractions\SMPR " & departdate & ".xlsx" ' Accéder à la feuille Set xlApp = CreateObject("Excel.Application") Set xlBook = xlApp.Workbooks.Open(CurrentProject.Path & "\Extractions\SMPR " & departdate & ".xlsx") xlApp.Worksheets("QR3 FRONTAL 2").Visible = True xlApp.Sheets("QR3 FRONTAL 2").Select xlApp.ActiveSheet.Range("A2:H10000").Value = "" 'pour réinitialiser la plage Set db = CurrentDb ' Créer un jeu d'enregistrements avec la table tAExporter Set rs = db.OpenRecordset("QR3-Frontal-2") ' Copier chaque enregistrement cellule par cellule i = 2 Do Until rs.EOF For j = 0 To rs.Fields.Count - 1 If j < 26 Then xlApp.ActiveSheet.Range(Chr(65 + j) & i) = rs(j) Else xlApp.ActiveSheet.Range("A" & Chr(39 + j) & i) = rs(j) End If Next j i = i + 1 rs.MoveNext Loop xlApp.Worksheets("QR3 FRONTAL 2").Visible = False xlApp.Worksheets("DATE - MOIS").Visible = True xlApp.Sheets("DATE - MOIS").Select xlApp.ActiveSheet.Range("B1") = Me.Texte46 xlApp.ActiveSheet.Range("B2") = Me.Texte48 xlApp.Worksheets("DATE - MOIS").Visible = False xlApp.Worksheets("QR7 B3").Visible = True xlApp.Sheets("QR7 B3").Select xlApp.ActiveSheet.Range("A2:H1000").Value = "" 'pour réinitialiser la plage Set db = CurrentDb ' Créer un jeu d'enregistrements avec la table tAExporter Set rs = db.OpenRecordset("QR7-B3") ' Copier chaque enregistrement cellule par cellule i = 2 Do Until rs.EOF For j = 0 To rs.Fields.Count - 1 If j < 26 Then xlApp.ActiveSheet.Range(Chr(65 + j) & i) = rs(j) Else xlApp.ActiveSheet.Range("A" & Chr(39 + j) & i) = rs(j) End If Next j i = i + 1 rs.MoveNext Loop xlApp.Worksheets("QR7 B3").Visible = False ' Code de fermeture xlApp.DisplayAlerts = False 'pour éviter la demande compatibilité xlBook.Close (True) xlApp.DisplayAlerts = True xlApp.Quit Set xlSheet = Nothing Set xlBook = Nothing Set xlApp = Nothing rs.Close Set rs = Nothing Set db = Nothing 'Message de bonne arrivée MsgBox "Durée d'exécution : " & Now() - depart End Sub
Auriez vous une idee de comment procéder pour réduire cet export dans un temps raisonnable ?
Vous remerciant d'avance
Partager