Private Sub foo_TG()
DoCmd.SetWarnings False
Dim rsExport As Recordset
Dim i As Integer
Set rsExport = CurrentDb.OpenRecordset("qry_Export_Step_Thru")
Dim flds As DAO.Fields
Dim fld As DAO.Field
Dim strExport As String
Dim strSheetName As String
Dim strCellRef As String
Dim strheader As String
Set flds = rsExport.Fields
Set fld = flds("qryName")
Set fldsWSName = rsExport.Fields
Set fldWSName = fldsWSName("SheetName")
Set fldsCellRef = rsExport.Fields
Set fldCellRef = fldsCellRef("CellRef")
Set fldsHeader = rsExport.Fields
Set fldHeader = fldsHeader("Header")
With rsExport
.MoveFirst
Do While Not .EOF
strExport = fld
strSheetName = fldWSName
strCellRef = fldCellRef
strheader = fldHeader
Dim lngColumn As Long
Dim xlx As Object, xlw As Object, xls As Object, xlc As Object
Dim dbs As DAO.Database
Dim rst As DAO.Recordset
Dim blnEXCEL As Boolean, blnHeaderRow As Boolean
blnEXCEL = False
blnHeaderRow = strheader
On Error Resume Next
Set xlx = GetObject(, "Excel.Application")
If Err.Number <> 0 Then
Set xlx = CreateObject("Excel.Application")
blnEXCEL = True
End If
Err.Clear
On Error GoTo 0
xlx.Visible = True
Set xlw = xlx.Workbooks.Open("C:\Desktop\Template.xlsm")
xlw.Application.Calculation = xlManual
xlw.Application.DisplayAlerts = False
Set xls = xlw.Worksheets(strSheetName)
Set xlc = xls.Range(strCellRef) ' this is the first cell into which data go
Set dbs = CurrentDb()
Set rst = dbs.OpenRecordset(strExport, dbOpenDynaset, dbReadOnly)
If Not rst Is Nothing Then
If rst.EOF = False And rst.BOF = False Then
rst.MoveFirst
If blnHeaderRow = True Then
For lngColumn = 0 To rst.Fields.Count - 1
xlc.Offset(0, lngColumn).Value = rst.Fields(lngColumn).Name
Next lngColumn
Set xlc = xlc.Offset(1, 0)
End If
xlc.CopyFromRecordset rst
End If
rst.Close
Set rst = Nothing
dbs.Close
Set dbs = Nothing
Set xlc = Nothing
Set xls = Nothing
xlw.Application.Calculation = xlAutomatic
xlw.Application.DisplayAlerts = True
xlw.Close True
Set xlw = Nothing
If blnEXCEL = True Then xlx.Quit
Set xlx = Nothing
.MoveNext
Loop
End With
End Sub
