Option Compare Database
Option Explicit
Public Sub ExportMultiTableToExcel(ByVal ExcelFile As String, _
ByVal StartRangeToExport As String, _
ParamArray AccessTables() As Variant)
' variable declaration
Dim xla As Excel.Application
Dim xlw As Excel.Workbook
Dim xls As Excel.WorkSheet
Dim ars As DAO.Recordset
Dim tableName As Variant
Dim bolExists As Boolean
Dim bolAppend As Boolean
Dim strColumn As String
Dim lngRow As Long
Dim strMsg As String
strColumn = getColumnName(StartRangeToExport)
lngRow = getRowValue(StartRangeToExport)
' open excel application, workbook, worksheet
' check if workbook exists, create one if not
If Dir(ExcelFile) <> "" Then
bolExists = True
If MsgBox("Excel file already exists. Do you wish to Overwrite it?", vbExclamation + vbYesNo, "Export Tables") = vbYes Then
Kill ExcelFile
Else
If MsgBox("Do you wish to Append new data to it?", vbInformation + vbYesNo, "Export Tables") = vbNo Then
Exit Sub
End If
bolAppend = True
End If
End If
Set xla = New Excel.Application
If (bolExists = True And bolAppend = True) Then
Set xlw = xla.Workbooks.Open(ExcelFile)
Else
Set xlw = xla.Workbooks.Add
End If
Set xls = xlw.Sheets(1)
' loop through each table and save the worksheet
If (bolAppend = True) Then
lngRow = xls.UsedRange.Rows.Count + 3
End If
With xls
For Each tableName In AccessTables
strMsg = strMsg & tableName & ", "
Set ars = CurrentDb.OpenRecordset(tableName, dbOpenSnapshot)
' write the column header
createColumnHeader xls, StartRangeToExport, ars
' export the recordset to this sheet
lngRow = lngRow + 1
lngRow = .Range(strColumn & lngRow).CopyFromRecordset(ars) + lngRow + 2
StartRangeToExport = strColumn & lngRow
' close this recordset
ars.Close
Set ars = Nothing
Next
End With
' save the workbook
If (bolAppend = True) Then
xlw.Save
Else
xlw.SaveAs ExcelFile
End If
' housekeeping
Set xls = Nothing
Set xlw = Nothing
xla.Quit
Set xla = Nothing
strMsg = Left(strMsg, Len(strMsg) - Len(", ")) & " table(s) appended to " & ExcelFile
MsgBox strMsg, vbInformation + vbOKOnly, "Export Tables"
End Sub
' write the column header to the worksheet
Private Sub createColumnHeader(ByVal WorkSheet As Excel.WorkSheet, _
ByVal RangeName As String, _
ByRef Record As DAO.Recordset)
Dim intLoop As Integer
Dim lngColumn As Long
Dim lngRow As Long
lngColumn = ColumnLetterToNumber(WorkSheet, getColumnName(RangeName))
lngRow = getRowValue(RangeName)
With WorkSheet
For intLoop = 1 To Record.Fields.Count
.Range(ColumnNumberToLetter(WorkSheet, lngColumn) & lngRow).Value = _
Record.Fields(intLoop - 1).Name
lngColumn = lngColumn + 1
Next
End With
End Sub
Public Function ColumnNumberToLetter(ByRef xlsheet As Excel.WorkSheet, ByVal ColumnNumber As Long) As String
ColumnNumberToLetter = Split(xlsheet.Cells(1, ColumnNumber).Address(True, False), "$")(0)
End Function
Public Function ColumnLetterToNumber(ByRef xlsheet As Excel.WorkSheet, ByVal ColumnName As String) As Long
ColumnLetterToNumber = xlsheet.Range(ColumnName & 1).Column
End Function
Private Function getColumnName(RangeName As String) As String
Dim intLoop As Integer
Dim strColumn As String
intLoop = 1
strColumn = Mid(RangeName, intLoop, 1)
While (IsNumeric(strColumn) = False)
getColumnName = getColumnName & strColumn
intLoop = intLoop + 1
strColumn = Mid(RangeName, intLoop, 1)
Wend
End Function
Private Function getRowValue(RangeName As String) As Long
Dim intLoop As Integer
Dim strRow As String
Dim strRows
intLoop = Len(RangeName)
strRow = Mid(RangeName, intLoop, 1)
While (IsNumeric(strRow) = True)
strRows = strRow & strRows
intLoop = intLoop - 1
strRow = Mid(RangeName, intLoop, 1)
Wend
getRowValue = Val(strRows)
End Function
Private Function FileNameOnly(ByVal PathFile As String) As String
FileNameOnly = PathFile
If InStr(PathFile, "\") <> 0 Then
FileNameOnly = Mid(PathFile, InStrRev(PathFile, "\") + 1)
End If
End Function
