Copy field names to Excel along with recordset

  • Thread starter Thread starter Stein
  • Start date Start date
S

Stein

I am copying recordsets to multiple tabs in an Excel spreadsheet (code
below). It works beautifully, except that I need the field names to
come across with the records. In other words, I need column headers
in the resulting Excel sheets.

Here's what I have so far:

Function Save_to_Excel()
Dim XLapp As Excel.Application
Dim xlWB As Excel.Workbook
Dim xlWS As Excel.Worksheet

Set XLapp = New Excel.Application

Set xlWB = XLapp.Workbooks.Open("C:\Disruption
Clean\OutputTemplate.xls")

Set xlWS = xlWB.Worksheets("Valid")

Dim rst As Recordset

Set XLapp = New Excel.Application

Set rst = CurrentDb.OpenRecordset("qryOutputValid")

xlWS.Range("A6500").End(xlUp).Offset(1, 0).CopyFromRecordset rst

rst.Close

Set xlWS = xlWB.Worksheets("Invalid")

Set rst = CurrentDb.OpenRecordset("qryOutputInvalid")

xlWS.Range("A6500").End(xlUp).Offset(1, 0).CopyFromRecordset rst

xlWB.SaveAs ("C:\Disruption Clean\Analysis.xls")
xlWB.Close True

Set xlWS = Nothing
Set xlWB = Nothing

XLapp.Quit

Set XLapp = Nothing

End Function
 
I added a few lines to your code to write the field names from the
recordset.


Function Save_to_Excel()
Dim XLapp As Excel.Application
Dim xlWB As Excel.Workbook
Dim xlWS As Excel.Worksheet

'****************************************************
' new code added below
'
Dim lngFields As Long

'
'****************************************************

Set XLapp = New Excel.Application

Set xlWB = XLapp.Workbooks.Open("C:\Disruption
Clean\OutputTemplate.xls")

Set xlWS = xlWB.Worksheets("Valid")

Dim rst As Recordset

Set XLapp = New Excel.Application

Set rst = CurrentDb.OpenRecordset("qryOutputValid")

xlWS.Range("A6500").End(xlUp).Offset(1, 0).CopyFromRecordset rst

rst.Close

Set xlWS = xlWB.Worksheets("Invalid")

Set rst = CurrentDb.OpenRecordset("qryOutputInvalid")

'****************************************************
' new code added below
'
For lngFields = 0 To rst.Fields.Count - 1
xlWS.Range(xlWS.Cells(1, lngFields + 1).Value = _
rst.Fields(lngFields).Name
Next lngFields
'
'****************************************************

xlWS.Range("A6500").End(xlUp).Offset(1, 0).CopyFromRecordset rst

xlWB.SaveAs ("C:\Disruption Clean\Analysis.xls")
xlWB.Close True

Set xlWS = Nothing
Set xlWB = Nothing

XLapp.Quit

Set XLapp = Nothing

End Function
 
Back
Top