How to export data that’s to be archived to an Excel worksheet, and then remove the exported records from the Access tables.
Access Archon #143
The procedure that exports the data to be archived to an Excel worksheet, and then removes the exported records from the Access tables, is listed below:
Module VBA Code
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
Notes
Instead of creating a new Excel worksheet from an Excel template, you could export the data directly to a plain worksheet, using the TransferSpreadsheet method. However, I chose to use a template so I could do some basic formatting and list the date range within the worksheet.
For an even fancier worksheet, you could record an Excel macro that eliminates duplicate values and creates a grouped and shaded worksheet, and then insert that code (with some editing) into the ArchiveData procedure.
References
The code in the sample database needs the following references (in addition to the default references):
Microsoft DAO 3.6 Object Library
Microsoft Scripting Runtime
Microsoft Excel 11.0 Object Library
If you import code or objects into a database of your own, you may need to set one or more of these references. The version number may differ, depending on your Office version; check the version you have. References are set in the References dialog, opened from the VBA window. For more information on working with references, see Access Archon #107, Working with References.
Supporting Files
The zip file containing this article, in Word format, plus the supporting file(s), may be downloaded from the Access Archon page of my Web site. It is accarch143.zip, which is the last entry in the table of Access Archon columns for Access Watch.
|
Document Name |
Document Type |
Place in |
|
Archiving.mdb |
Access 2000 database (can also be used in higher versions of Access) | |
|
Backup.mdb |
Access 2000 database (can also be used in higher versions of Access) |
Wherever you want |
|
Orders Archive.xlt |
Excel template |
Same folder as database you want to archive |
