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