VBA: Need to Add Access Query Headers to Excel Export

[shlobodon]

Hello,

I have a macro that moves an Access query to Excel. I am unable to bring the headers from that query into Excel, but I need to for organizing purposes.

This is the working code that does everything but bring in headers.

Option Compare Text
Sub diversityauto()
StrDBPath = "K:\nataccts\Rob D\Diversity Report Automation\Supplier Diversity Report Clone.accdb"
Windows("Diversity Report List.xlsx").Activate
Sheets("Report List").Select
LastRow = Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To LastRow
Application.AskToUpdateLinks = False
Application.DisplayAlerts = False
Set costsavings = Workbooks.Open("K:\nataccts\Rob D\Diversity Report Automation\Diversity Supplier Report_Template.xlsx")
Windows("Diversity Report List.xlsx").Activate
Sheets("Report List").Select
blnHeaderRow = True
CBA1 = Cells(i, "C").Value
Set con = New ADODB.Connection
With con
.Provider = "Microsoft.ACE.OLEDB.12.0"
.Open StrDBPath
End With
sSQL = "TRANSFORM Sum([Spend by Supplier].[Sales Amount]) AS [SumOfSales Amount] SELECT [Spend by Supplier].[Cal year / month] FROM [Spend by Supplier] INNER JOIN [2015 Diversity File Compacted] ON [Spend by Supplier].[Supplier Code] = [2015 Diversity File Compacted].[Vendor No] WHERE [Spend by Supplier].CBA1 GROUP BY [Spend by Supplier].[Cal year / month] PIVOT [2015 Diversity File Compacted].[Diverse Category];"
Set rs = New ADODB.Recordset
rs.CursorLocation = adUseServer
rs.Open Source:=sSQL, ActiveConnection:=con, CursorType:=AdForwardOnly, LockType:=adLockOptimistic, Options:=adCmdText
Windows("Diversity Supplier Report_Template.xlsx").Activate
Sheets("Diversity Summary by Month").Select
Range("B33").CopyFromRecordset rs
rs.Close
con.Close
Next i
End Sub

 

[Norie]

You need to loop through the Fields collection of the recordset rs to get the field names.[

With Sheets("Diversity Summary by Month")

    Set rngHdrs = .Range("B32")

    For Each fld In rs.Fields
        rngHdrs.Value = fld.Name
        Set rngHdrs = rngHdrs.Offset(,1)
    Next fld

    .Range("B33").CopyFromRecordset rs

End With

 

[shlobodon]

Yep! That worked perfectly! Thank you!