Public Sub ArchiveData(dteStart As Date, dteEnd As Date)
On Error GoTo ErrorHandler
Dim appExcel As Excel.Application
Dim intReturn As Integer
Dim lngCount As Long
Dim n As Long
Dim rng As Excel.Range
Dim rngStart As Excel.Range
Dim strDBPath As String
Dim strPrompt As String
Dim strQuery As String
Dim strSaveName As String
Dim strSheet As String
Dim strSheetTitle As String
Dim strSQL As String
Dim strTemplate As String
Dim strTemplateFile As String
Dim strTemplatePath As String
Dim strTitle As String
Dim wkb As Excel.Workbook
Dim wks As Excel.Worksheet
strQuery = "qryArchive"
Set dbs = CurrentDb
strSQL = "SELECT * FROM tblOrders WHERE " _
& "[ShippedDate] Between #" & dteStart & "# And #" & dteEnd & "#;"
Debug.Print "SQL for " & strQuery & ": " & strSQL
lngCount = CreateAndTestQuery(strQuery, strSQL)
Debug.Print "No. of items found: " & lngCount
If lngCount = 0 Then
strPrompt = "No orders found for this date range; canceling archiving"
strTitle = "Canceling"
MsgBox strPrompt, vbOKOnly + vbCritical, strTitle
GoTo ErrorHandlerExit
Else
strPrompt = lngCount & " orders found in this date range; archive them?"
strTitle = "Archiving"
intReturn = MsgBox(strPrompt, vbYesNo + vbQuestion, strTitle)
If intReturn = vbNo Then
GoTo ErrorHandlerExit
End If
End If
'Create new worksheet from template and export data to it
strDBPath = Application.CurrentProject.Path & "\"
Debug.Print "Current database path: " & strDBPath
strTemplate = "Orders Archive.xlt"
strTemplateFile = strDBPath & strTemplate
If TestFileExists(strTemplateFile) = False Then
strTitle = "Template not found"
strPrompt = "Excel template 'Orders Archive.xlt'" _
& " not found in " & strDBPath & ";" & vbCrLf _
& "please put template in this folder and try again"
MsgBox strPrompt, vbCritical + vbOKOnly, strTitle
GoTo ErrorHandlerExit
Else
Debug.Print "Excel template used: " & strTemplateFile
End If
Set appExcel = GetObject(, "Excel.Application")
Set rst = dbs.OpenRecordset("qryRecordsToArchive")
Set wkb = appExcel.Workbooks.Add(strTemplateFile)
Set wks = wkb.Sheets(1)
wks.Activate
appExcel.Visible = True
'Write date range to title cell
Set rng = wks.Range("A1")
strSheetTitle = "Archived Orders for " & Format(dteStart, "d-mmm-yyyy") _
& " to " & Format(dteEnd, "d-mmm-yyyy")
Debug.Print "Sheet title: " & strSheetTitle
rng.Value = strSheetTitle
'Go to first data cell
Set rngStart = wks.Range("A4")
Set rng = wks.Range("A4")
'Reset lngcount to number of records in query
rst.MoveLast
rst.MoveFirst
lngCount = rst.RecordCount
For n = 1 To lngCount
'Write data from recordset to worksheet
rng.Value = Nz(rst![OrderID])
Set rng = rng.Offset(columnoffset:=1)
rng.Value = Nz(rst![Customer])
Set rng = rng.Offset(columnoffset:=1)
rng.Value = Nz(rst![Employee])
Set rng = rng.Offset(columnoffset:=1)
rng.Value = Nz(rst![OrderDate])
Set rng = rng.Offset(columnoffset:=1)
rng.Value = Nz(rst![RequiredDate])
Set rng = rng.Offset(columnoffset:=1)
rng.Value = Nz(rst![ShippedDate])
Set rng = rng.Offset(columnoffset:=1)
rng.Value = Nz(rst![Shipper])
Set rng = rng.Offset(columnoffset:=1)
rng.Value = Nz(rst![Freight])
Set rng = rng.Offset(columnoffset:=1)
rng.Value = Nz(rst![ShipName])
Set rng = rng.Offset(columnoffset:=1)
rng.Value = Nz(rst![ShipAddress])
Set rng = rng.Offset(columnoffset:=1)
rng.Value = Nz(rst![ShipCity])
Set rng = rng.Offset(columnoffset:=1)
rng.Value = Nz(rst![ShipRegion])
Set rng = rng.Offset(columnoffset:=1)
rng.Value = Nz(rst![ShipPostalCode])
Set rng = rng.Offset(columnoffset:=1)
rng.Value = Nz(rst![ShipCountry])
Set rng = rng.Offset(columnoffset:=1)
rng.Value = Nz(rst![Product])
Set rng = rng.Offset(columnoffset:=1)
rng.Value = Nz(rst![UnitPrice])
Set rng = rng.Offset(columnoffset:=1)
rng.Value = Nz(rst![Quantity])
Set rng = rng.Offset(columnoffset:=1)
rng.Value = Nz(rst![Discount])
'Go to next row
rst.MoveNext
Set rng = rngStart.Offset(rowoffset:=n)
Next n
'Save and close filled-in worksheet, using workbook save name
'with date range
strSaveName = strDBPath & strSheetTitle & ".xls"
Debug.Print "Time sheet save name: " & strSaveName
ChDir strDBPath
On Error Resume Next
'If there already is a saved worksheet with this name, delete it
Kill strSaveName
On Error GoTo ErrorHandler
wkb.SaveAs FileName:=strSaveName, FileFormat:=xlNormal
wkb.Close
rst.Close
appExcel.Visible = False
Set appExcel = Nothing
strTitle = "Workbook created"
strPrompt = "Archive workbook '" & strSheetTitle & "'" & vbCrLf _
& "created in " & strDBPath
MsgBox strPrompt, vbOKOnly + vbInformation, strTitle
'Delete archived records, processing "many" table first
strSQL = "DELETE tblOrderDetails.*, tblOrders.ShippedDate " _
& "FROM tblOrderDetails INNER JOIN qryArchive " _
& "ON tblOrderDetails.OrderID = qryArchive.OrderID;"
DoCmd.RunSQL strSQL
strSQL = "DELETE tblOrders.* FROM tblOrders WHERE " _
& "[ShippedDate] Between #" & dteStart & "# And #" & dteEnd & "#;"
DoCmd.RunSQL strSQL
strTitle = "Records cleared"
strPrompt = "Archived records from " & Format(dteStart, "d-mmm-yyyy") _
& " to " & Format(dteEnd, "d-mmm-yyyy") & " cleared from tables"
MsgBox strPrompt, vbOKOnly + vbInformation, strTitle
ErrorHandlerExit:
Exit Sub
ErrorHandler:
'Excel is not running; open Excel with CreateObject
If Err.Number = 429 Then
Set appExcel = CreateObject("Excel.Application")
Resume Next
Else
MsgBox "Error No: " & Err.Number & "; Description: "
Resume ErrorHandlerExit
End If
End Sub
I'll try my best: 
