Code:
Option Compare Database
Option Explicit
Public param As String
Public Function CreateQueryToExportToExcel()
Dim saveloc As String, strWorksheetPath As String, xl As Object, wb As Object
Dim exportsheet As Object, Header As Variant, OIHeader As Variant
Dim db As DAO.Database, ExportRecordSet As DAO.Recordset
Dim row As Integer, i As Integer, colLetter As String
'Turning warnings off for procedure to execute
'Commented out to get an error message if present
'DoCmd.SetWarnings False
'Setting Save location
saveloc = Environ("USERPROFILE") & "\Desktop\"
saveloc = strWorksheetPath & "Test.xlsx"
Set db = CurrentDb '<----------------- KD2017 Uncommented this line
'Instantiating Excel
Set xl = CreateObject("Excel.Application")
'Turning off Excel Warnings
'Turning off warnings for testing
'xl.DisplayAlerts = False
'Adding new workbook to Excel Object
Set wb = xl.Workbooks.Add
'Naming worksheets
Set exportsheet = wb.Worksheets(1)
exportsheet.Name = "Test"
'Setting Excel To Visible
xl.Application.Visible = True
'Creating Array For Headers
Header = Array("One", "Two", "Threre", "Four", "Five", "Six", "Seven", "Eight", "Nine", "Ten", "Eleven", "Twelve", "Thirteen", "Fourteen", "Fifteen")
'Setting which elements of Array Go To Sheet1
OIHeader = Array(0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14) '<----------------- KD2017 Deleted 15
'Actual Query that will be used to export to Excel
Set ExportRecordSet = db.OpenRecordset(" SELECT One, Two, Threre, Four, Five, Six, Seven, Eight, Nine, Ten, Eleven, Twelve, Thirteen, Fourteen, Fifteen " & _
" from testdata WHERE [four] ='" & param & "';")
row = 1
'Writing Header Info To Sheet1
For i = LBound(OIHeader) To UBound(OIHeader)
exportsheet.Cells(row, i + 1).Value = Header(OIHeader(i))
Next i
'Formatting Text For Sheet1
exportsheet.Range("A1:P1").Font.Bold = True
exportsheet.Range("A1:P1").Font.Size = 16
exportsheet.Range("A1:P1").Interior.ColorIndex = 15
row = row + 1
If Not ExportRecordSet.EOF Then
While Not ExportRecordSet.EOF
'Writing Data To Sheet 1
exportsheet.Cells(row, 1).Value = ExportRecordSet("One")
exportsheet.Cells(row, 2).Value = ExportRecordSet("Two")
exportsheet.Cells(row, 3).Value = ExportRecordSet("Threre")
exportsheet.Cells(row, 4).Value = ExportRecordSet("Four")
exportsheet.Cells(row, 5).Value = ExportRecordSet("Five")
exportsheet.Cells(row, 6).Value = ExportRecordSet("Six")
exportsheet.Cells(row, 7).Value = ExportRecordSet("Seven")
exportsheet.Cells(row, 8).Value = ExportRecordSet("Eight")
exportsheet.Cells(row, 9).Value = ExportRecordSet("Nine")
exportsheet.Cells(row, 10).Value = ExportRecordSet("Ten")
exportsheet.Cells(row, 11).Value = ExportRecordSet("Eleven")
exportsheet.Cells(row, 12).Value = ExportRecordSet("Twelve")
exportsheet.Cells(row, 13).Value = ExportRecordSet("Thirteen")
exportsheet.Cells(row, 14).Value = ExportRecordSet("Fourteen")
exportsheet.Cells(row, 15).Value = ExportRecordSet("Fifteen")
ExportRecordSet.MoveNext
row = row + 1
Wend
ExportRecordSet.Close
End If
'Autofitting Headers
Dim ColumnLetter() As Variant '<----------------- KD2017 declared this variable
ColumnLetter = Array("A", "B", "C", "D", "E", "F", "G", "H", "I", "J", "K", "L", "M", "N", "O", "P") '<----------------- KD2017 Note P is the 16th column, data only has 15 columns
For i = 0 To 15 '<----------------- KD2017 adjusted range
colLetter = ColumnLetter(i)
exportsheet.Columns(colLetter & ":" & colLetter).Autofit
Next i
'Selecting the first worksheet
exportsheet.Activate
exportsheet.Range("A1").Activate
'Saving the workbook
wb.SaveAs FileName:=saveloc
'Closing the workbook
wb.Close
'Turning warnings back on since procedure is complete
'DoCmd.SetWarnings True
'Turning the Excel Warnings Back on
'xl.DisplayAlerts = False
End Function
Sub test() '<----------------- KD2017 sub to run function
param = "Hi"
CreateQueryToExportToExcel
End Sub