---Soumis par Dev Ashish---
Transfert d'enregistrements vers Excel de par Automation.
La méthode d'Excel CopyFromRecordset est probablement la façon la plus rapide de copier des enregistrements en passant par Automation. La méthode permet également une bonne flexibilité quand à où et comment les enregistrements sont copiés. Vous pouvez utiliser une région (named range) dans une feuille existante, ou encore, en spécifiant une colonne comme point de départ pour les enregistrements.
Voici quelques façons de transférer un recordset vers Excel. Pour utiliser ces exemples, s'assurer d'abord d'établir la référence à "Microsoft Excel 8.0 Object Library" sous le menu: Tools/References.
'************* Code Start ***************** Sub sCopyFromRS() 'Envoyer les enregistrements à la première feuille 'd'un nouveau workbook ' Dim rs As Recordset Dim intMaxCol As Integer Dim intMaxRow As Integer Dim objXL As Excel.Application Dim objWkb As Workbook Dim objSht As Worksheet Set rs = CurrentDb.OpenRecordset("Customers", _ dbOpenSnapshot) intMaxCol = rs.Fields.Count If rs.RecordCount > 0 Then rs.MoveLast: rs.MoveFirst intMaxRow = rs.RecordCount Set objXL = New Excel.Application With objXL .Visible = True Set objWkb = .Workbooks.Add Set objSht = objWkb.Worksheets(1) With objSht .Range(.Cells(1, 1), .Cells(intMaxRow, _ intMaxCol)).CopyFromRecordset rs End With End With End If End Sub Sub sCopyRSExample() 'Copier les 20 000 premiers enregistements 'dans un feuille existante ' Dim objXL As Excel.Application Dim objWkb As Excel.Workbook Dim objSht As Excel.Worksheet Dim db As Database Dim rs As Recordset Dim intLastCol As Integer Const conMAX_ROWS = 20000 Const conSHT_NAME = "SomeSheet" Const conWKB_NAME = "J:\temp\book1.xls" Set db = CurrentDb Set objXL = New Excel.Application Set rs = db.OpenRecordset("Customers", dbOpenSnapshot) With objXL .Visible = True Set objWkb = .Workbooks.Open(conWKB_NAME) On Error Resume Next Set objSht = objWkb.Worksheets(conSHT_NAME) If Not Err.Number = 0 Then Set objSht = objWkb.Worksheets.Add objSht.Name = conSHT_NAME End If Err.Clear On Error GoTo 0 intLastCol = objSht.UsedRange.Columns.Count With objSht .Range(.Cells(1, 1), .Cells(conMAX_ROWS, _ intLastCol)).ClearContents .Range(.Cells(1, 1), _ .Cells(1, rs.Fields.Count)).Font.Bold = True .Range("A2").CopyFromRecordset rs End With End With Set objSht = Nothing Set objWkb = Nothing Set objXL = Nothing Set rs = Nothing Set db = Nothing End Sub Sub sCopyRSToNamedRange() 'Copier les enregistrements dans une 'région (name range) d'une feuille d'un 'workbook ' Dim objXL As Excel.Application Dim objWkb As Excel.Workbook Dim objSht As Excel.Worksheet Dim db As Database Dim rs As Recordset Const conMAX_ROWS = 20000 Const conSHT_NAME = "SomeSheet" Const conWKB_NAME = "c:\temp\book1.xls" Const conRANGE = "RangeForRS" Set db = CurrentDb Set objXL = New Excel.Application Set rs = db.OpenRecordset("Customers", dbOpenSnapshot) With objXL .Visible = True Set objWkb = .Workbooks.Open(conWKB_NAME) On Error Resume Next Set objSht = objWkb.Worksheets(conSHT_NAME) If Not Err.Number = 0 Then Set objSht = objWkb.Worksheets.Add objSht.Name = conSHT_NAME End If Err.Clear On Error GoTo 0 objSht.Range(conRANGE).CopyFromRecordset rs End With Set objSht = Nothing Set objWkb = Nothing Set objXL = Nothing Set rs = Nothing Set db = Nothing End Sub '************* Code End *****************