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 91 92 93 94 95 96 97 98 99 100 101
| Sub ExportDansFeuille(sNomReq As String, _
sFichXL As String, _
sNomFeuille As String, _
Optional bCreerFichier As Boolean = False)
Dim xlApp As Object 'Excel.Application
Dim xlWbk As Object 'Excel.Workbook
Dim xlSht As Object 'Excel.Worksheet
Dim xlRg As Object 'Excel.Range
Dim bCreerFeuille As Boolean
Dim db As DAO.Database, rs As DAO.Recordset
Dim lIdx As Long
On Error GoTo ErrH
If (bCreerFichier) Then
' Le détruire si existe déjà
If Len(Dir(sFichXL, vbNormal)) > 0 Then Kill sFichXL
Else
If Len(Dir(sFichXL, vbNormal)) = 0 Then
MsgBox "Le fichier Excel n'exsite pas", vbCritical, "Problème"
Exit Sub
End If
End If
Set db = CurrentDb
' Créer une nouvelle instance d'Excel
Set xlApp = CreateObject("Excel.Application")
xlApp.Visible = True ' pour déboguer
' Ouvrir oui créer le classeur
If bCreerFichier Then
Set xlWbk = xlApp.Workbooks.Add() ' crée nouveau classeur
Do While (xlWbk.Worksheets.Count > 1)
xlWbk.Worksheets(xlWbk.Worksheets.Count).Delete
Loop
Set xlSht = xlWbk.ActiveSheet
xlSht.Name = sNomFeuille
Else
Set xlWbk = xlApp.Workbooks.Open(sFichXL) ' ouvre classeur
bCreerFeuille = True
For Each xlSht In xlWbk.Worksheets
If xlSht.Name = sNomFeuille Then
bCreerFeuille = False
Exit For
End If
Next
End If
' créer feuille ?
If bCreerFeuille Then
Set xlSht = xlWbk.Worksheets.Add(, xlWbk.Worksheets(xlWbk.Worksheets.Count))
xlSht.Name = sNomFeuille
End If
' Référencer la cellule A1 de la feuille active
Set xlRg = xlSht.Range("A1")
' Se décaler plus bas si la feuille n'est pas vide
If xlSht.UsedRange.Address(True, True) <> "$A$1" Then
Set xlRg = xlRg.Offset(xlSht.UsedRange.Row + xlSht.UsedRange.Rows.Count)
End If
' *** requête à exporter ***
Set rs = db.OpenRecordset(sNomReq, dbOpenSnapshot)
' Copier les noms de colonnes
For lIdx = 0 To rs.Fields.Count - 1
xlRg.Offset(0, lIdx) = rs.Fields(lIdx).Name
xlRg.Offset(0, lIdx).Font.Bold = True
Next
' Copier les données
Set xlRg = xlRg.Offset(1, 0)
xlRg.CopyFromRecordset rs
' Fermer le recordset
rs.Close
' *** Finalisation ***
' Ajuster la largeur des colonnes
xlRg.Worksheet.Columns.AutoFit
' Sauver le classeur, puis le fermer
xlApp.DisplayAlerts = False
xlWbk.SaveAs sFichXL, , , , , False
xlApp.DisplayAlerts = True
xlWbk.Close
ExitS:
On Error Resume Next
' Libérer les variables objet
Set xlRg = Nothing ' (plage de cellules)
Set xlSht = Nothing ' (feuille)
Set xlWbk = Nothing ' (classeur)
' Fermer Excel
xlApp.Quit
' Libérer la variable objet xlApp (Excel)
Set xlApp = Nothing
Exit Sub
ErrH:
MsgBox "Erreur No." & Err.Number & vbCrLf & Err.Description, _
vbCritical, "Erreur"
Resume ExitS
Resume Next
End Sub |
Partager