Optimisation d'un export excel
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 :roll: (j'ai pas une grosse bete mais ca lui demande 2h30 ...:roll: ) Je vous propose mon code ci dessous
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
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
