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
| Sub sExportExcel()
Dim oRst As Recordset ' Recordset principal
Dim oRst2 As Recordset ' Recordset secondaire
Dim oQdftmp As QueryDef ' Définition requête temporaire à exporter
Dim stSql As String ' Texte Sql requète à exporter
'
Dim itCols As Integer ' Compteur des colonnes
Dim stPath As String ' Emplacement des classeurs
Dim stWkbkName As String ' Nom du document à créer
Dim oAppl As Excel.Application ' Application Excel
Dim oWkbk As Excel.Workbook ' L'objet classeur à créer
Dim oWSht As Excel.Worksheet ' L'objet feuille à créer
stPath = "D:\"
Set oAppl = CreateObject("excel.application")
Set oRst = CurrentDb.OpenRecordset("select * from Liste_SER order by code")
oAppl.DisplayAlerts = False ' désactivation des alertes
While Not oRst.EOF
'Exportation des information sur la SER
' nom du classeur à exporter
stWkbkName = "Export_" & oRst.Fields(0) & ".xls"
' Constitution de la requète
stSql = "select * from Liste_SER where code='" & oRst.Fields(0) & "';"
' Création de la requête
Set oQdftmp = CurrentDb.CreateQueryDef("Export_" & oRst.Fields(0), stSql)
' Transfert vers Excel
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel9, oQdftmp.Name, stPath & stWkbkName, True
' suppression requête temporaire
CurrentDb.QueryDefs.Delete "Export_" & oRst.Fields(0)
' -------------------------------------------------------------------------------------------------------
' Ajout des informations surface par essence
' ouverture du classeur en cours et création d'une nouvelle feuille
Set oWkbk = oAppl.Workbooks.Open(stPath & stWkbkName)
Set oWSht = oWkbk.Worksheets.Add
oWSht.Name = "Surface par essence" ' nom de la 1ère feuille à créer
' constitution de la source de données
Set oRst2 = CurrentDb.OpenRecordset("select * from [Req_Essence principale]" & " where [Code SER]='" & oRst.Fields(0) & "' order by [ST (ha)];")
' ajout des noms de colonnes ligne 1
If Not oRst2.EOF Then
With oRst2
For itCols = 0 To .Fields.Count - 1
oWSht.Cells(1, itCols + 1).Value = .Fields(itCols).Name
Next
'ajout des données
oWSht.Range("A2").CopyFromRecordset oRst2
End With
End If
' fermeture du recordset
oRst2.Close
' -------------------------------------------------------------------------------------------------------
' Ajout des informations Volume bois
' création d'une nouvelle feuille
Set oWSht = oWkbk.Worksheets.Add
oWSht.Name = "Volume Bois" ' nom de la 2ème feuille à créer
' constitution de la source de données
Set oRst2 = CurrentDb.OpenRecordset("select * from Req_Volume_Bois" & " where [Code SER]='" & oRst.Fields(0) & "';")
' ajout des noms de colonnes ligne 1
If Not oRst2.EOF Then
With oRst2
For itCols = 0 To .Fields.Count - 1
oWSht.Cells(1, itCols + 1).Value = .Fields(itCols).Name
Next
' ajout des données
oWSht.Range("A2").CopyFromRecordset oRst2
End With
End If
' réordonnancement des feuilles
For itCols = 1 To 2
oWkbk.Sheets(3).Select
oWkbk.ActiveSheet.Move Before:=oWkbk.Sheets(itCols)
Next itCols
oWkbk.Sheets(1).Select
' fermeture du recordset
oRst2.Close
' sauvegarde et fermeture du classeur
oWkbk.Save
oWkbk.Close
oRst.MoveNext
Wend
' Fermeture des objets
oAppl.Quit
oRst.Close
Set oRst = Nothing
Set oRst2 = Nothing
End Sub |
Partager