Discussion :

[vdbadr]

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

[titi95]

Bonjour

A première vue, je pense que ce sont les 2 remplissages cellule par cellule qui prennent du temps.
Il serait intéressant, pour un, que tu en mesures le temps d’exécution.

Il faudrait utiliser une action plus globale, comme avec TransferSpreadsheet par exemple. (c'est ce que je privilégie pour mes exports Excel)
Regarde ce qui est possible dans ton cas.

Titi95

[vdbadr]

Je sais que cet export case à case ralenti l'execution (c'etait le moment pour faire un export "controlé" sans toucher à la mise en forme ou au format de la case qui receptionne)
je vais regarder du coté d'un transfertspreadsheet
Merci

[tee_grandbois]

Bonjour,
tu peux essayer la méthode CopyFromRecordSet : https://msdn.microsoft.com/fr-fr/vba...t-method-excel