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
|
Sub ExporteDsExcelAvecModele()
' Variables pour manipuler Excel
Dim xlApp As Excel.Application, xlAppCreated As Boolean
Dim xlWbk As Excel.Workbook, xlSht As Excel.Worksheet
Dim lgCntLigne As Long
' Variables données sources
Dim db As DAO.Database, rs As DAO.Recordset
' Variable spécifiques à l'appli
Dim strope As String
On Error GoTo ErrH
Set db = CurrentDb
' Ouvre la requête
Set rs = db.OpenRecordset("SELECT [suivi DGD excel].NOM_OPERATION, [suivi DGD excel].NUM_LOT, [suivi DGD excel].NOM_ENTREPRISE FROM [suivi DGD excel] ORDER BY [suivi DGD excel].NUM_LOT")
' Si vide sortir
If rs.EOF Then GoTo ExitSub
' Tente de récupérer une instance d'Excel déjà créée
Set xlApp = GetObject(, "Excel.Application")
' Sinon, crée une nouvelle instance d'Excel
If xlApp Is Nothing Then
Set xlApp = CreateObject("Excel.Application")
xlAppCreated = True
End If
' Crée un nouveau Classeur à partir d'un modèle
Set xlWbk = xlApp.Workbooks.Add(Environ("USERPROFILE") & "\access_pc3d\doc\Financier chantier\465. Suivi DGD- DOE- PV. R4.xls")
' Référence la feuille active du classeur
Set xlSht = xlWbk.ActiveSheet
' Infos générales à mettre dans les cellules C2,C3,C5
strope = rs("NOM_OPERATION")
xlSht.Range("B6") = strope
'Détail (lignes) commence à partir de cellule B8
Do
'1ère colonne (offset 0)
xlSht.Range("A12").Offset(lgCntLigne, 0) = rs("NUM_LOT")
'2ème colonne (offset 1)
xlSht.Range("A12").Offset(lgCntLigne, 1) = rs("NOM_ENTREPRISE")
rs.MoveNext
' Incrémenter n° de ligne (relatif à la ligne 8 (B8))
lgCntLigne = lgCntLigne + 1
Loop Until rs.EOF
' Pour confirmer l'écrasement du Classeur s'il existe
xlApp.DisplayAlerts = False
' Sauvegarde du Classeur
xlWbk.SaveAs CurrentProject.Path & "\Cmde_" & strope, xlNormal
' Fermeture du Classeur
xlWbk.Close False
ExitSub:
' Réactive les messages d'avertissement
If Not (xlApp Is Nothing) Then xlApp.DisplayAlerts = True
' Libération des variables objets
Set rs = Nothing
Set db = Nothing
Set xlSht = Nothing
Set xlWbk = Nothing
If xlAppCreated = True And Not (xlApp Is Nothing) Then xlApp.Quit
Set xlApp = Nothing
Exit Sub
ErrH:
' Gestion d'erreurs
Select Case Err.Number
Case 429
' Ignorer Erreur causée par GetObject(, "Excel.Application")
Resume Next
Case Else
MsgBox "Erreur N. " & Err.Number & " : " & Err.Description
Resume ExitSub
End Select
End Sub |
Partager