On 20 Mar 2006 12:55:59 -0800, "bobh" <vu******@isp.com> wrote:
Hi All,
In Access97 I have a table that's greater than 65k records and I'm
looking for a VBA way to export the records to Excel.
Anyone have vba code to export from access to excel and have the code
use multiple excel tabs within a workbook????
Anyone have vba code that would create a temp table write 65,000
records to it, export those to excel, clean the temp table, append the
next 65,000 records, export it to excel with a different name, clear
the temp table, etc............ til it gets all the records from the
source table exported ???
thanks
bobh.
Something like the following should work.
Paste the following code into a standard module.
Change all instances of "ID" in the following sub to the name of your field in
tblCheck.
Change all instances of tblTestData in the following sub to the name of the
table containing the data to be exported.
Create a single field table called tblCheck. The single field (ID) should be the
same name and datatype as the primary key of your data table.
Create a query called qryExportData and paste the following into it's SQL view.
(change tblTestData and ID to suit your table)
SELECT TOP 65000 tblTestData.*
FROM tblTestData LEFT JOIN tblCheck ON tblTestData.ID = tblCheck.ID
WHERE (((tblCheck.ID) Is Null))
ORDER BY tblTestData.ID;
*The ExportToExcel function has been posted here previously by Chuck Grimsby.
The sub will create an excel spreadsheet with multiple worksheets each
containing 65,000 records.
After each loop, the ID's exported will be appended to tblCheck. qryExportData
will then ensure that these ID's are excluded from subsequent loops.
'================================================= ====
Sub Export()
Dim i As Integer
Dim x As Integer
Dim lngTotalRecords As Long
Dim intLoops As Integer
Dim strFileName As String
Dim strSheetName As String
Dim strSQL As String
Dim rst As DAO.Recordset
Dim db As DAO.Database
'name of spreadsheet to create (change to suit)
strFileName = "C:\Documents and Settings\bestfit\my documents\test.xls"
Set db = CurrentDb()
'how many records do we have
strSQL = "SELECT Count(ID) AS TotalRecords FROM tblTestData;"
Set rst = db.OpenRecordset(strSQL)
With rst
If .RecordCount <> 0 Then
.MoveFirst
lngTotalRecords = !TotalRecords
Else
lngTotalRecords = 0
End If
.Close
End With
Set rst = Nothing
'calc number of spreadsheets required
If lngTotalRecords Mod 65000 = 0 Then
intLoops = lngTotalRecords / 65000
Else
intLoops = (lngTotalRecords \ 65000) + 1
End If
'clear temp table
strSQL = "DELETE * FROM tblCheck;"
db.Execute strSQL, dbFailOnError
For i = 1 To intLoops
x = x + 1
'create spreadsheet
strSheetName = "Export" & x
Call ExportToExcel(strFileName, strSheetName, "qryExportData", False)
'write exported IDs to tblCheck
strSQL = "INSERT INTO tblCheck ( ID ) SELECT ID FROM qryExportData;"
db.Execute strSQL, dbFailOnError
Next i
Set rst = Nothing
Set db = Nothing
End Sub
'================================================= ====
Function ExportToExcel(strFileName As String, _
strSheetName As String, _
strSourceName As String, _
Optional bolMsgBoxWhenDone _
As Boolean = False) _
As Long
' strFileName is the Excel File to Create (or use)
' strSheetName is the sheet within the Excel file to create
' strSourceName is the table, query, or SQL string
' to use as the source
' bolMsgBoxWhenDone: Want a msgbox saying "Done"?
Dim myXLDB As DAO.Database
Dim myXLTDF As DAO.TableDef
Dim myXLRst As DAO.Recordset
Dim myDB As DAO.Database
Dim myRst As DAO.Recordset
Dim i As Long
Dim lngRC As Long
Dim lngStatus As Long
Dim varStatus As Variant
'Excel 2000
Set myXLDB = DBEngine.OpenDatabase(strFileName, _
dbDriverNoPrompt, _
False, _
"Excel 8.0")
'Excel 97
'Set myXLDB = DBEngine.OpenDatabase(strFileName, _
dbDriverNoPrompt, _
False, _
"Excel 7.0")
Set myDB = CurrentDb
Set myRst = myDB.OpenRecordset(strSourceName)
Set myXLTDF = myXLDB.CreateTableDef(strSheetName)
For i = 0 To myRst.Fields.Count - 1
With myXLTDF
Select Case myRst.Fields(i).Properties("Type")
Case 1
.Fields.Append .CreateField( _
myRst.Fields(i).Name, _
dbBoolean)
Case 2
.Fields.Append .CreateField( _
myRst.Fields(i).Name, _
dbByte)
Case 3
.Fields.Append .CreateField( _
myRst.Fields(i).Name, _
dbInteger)
Case 4
.Fields.Append .CreateField( _
myRst.Fields(i).Name, _
dbLong)
Case 5
.Fields.Append .CreateField( _
myRst.Fields(i).Name, _
dbCurrency)
Case 6
.Fields.Append .CreateField( _
myRst.Fields(i).Name, _
dbSingle)
Case 7
.Fields.Append .CreateField( _
myRst.Fields(i).Name, _
dbDouble)
Case 8
.Fields.Append .CreateField( _
myRst.Fields(i).Name, _
dbDate)
Case 9
.Fields.Append .CreateField( _
myRst.Fields(i).Name, _
dbBinary)
Case 10
.Fields.Append .CreateField( _
myRst.Fields(i).Name, _
dbText)
Case 11
.Fields.Append .CreateField( _
myRst.Fields(i).Name, _
dbLongBinary)
Case 12
.Fields.Append .CreateField( _
myRst.Fields(i).Name, _
dbMemo)
Case 13, 14
' unknown field types.
' No idea what these are!
Case 15
.Fields.Append .CreateField( _
myRst.Fields(i).Name, _
dbGUID)
Case 16
.Fields.Append .CreateField( _
myRst.Fields(i).Name, _
dbBigInt)
Case 17
.Fields.Append .CreateField( _
myRst.Fields(i).Name, _
dbVarBinary)
Case 18
.Fields.Append .CreateField( _
myRst.Fields(i).Name, _
dbChar)
Case 19
.Fields.Append .CreateField( _
myRst.Fields(i).Name, _
dbNumeric)
Case 20
.Fields.Append .CreateField( _
myRst.Fields(i).Name, _
dbDecimal)
Case 21
.Fields.Append .CreateField( _
myRst.Fields(i).Name, _
dbFloat)
Case 22
.Fields.Append .CreateField( _
myRst.Fields(i).Name, _
dbTime)
Case 23
.Fields.Append .CreateField( _
myRst.Fields(i).Name, _
dbTimeStamp)
End Select
End With
Next i
myXLDB.TableDefs.Append myXLTDF
Set myXLTDF = Nothing
myXLDB.TableDefs.Refresh
Set myXLRst = myXLDB.OpenRecordset(strSheetName)
myRst.MoveLast
lngRC = myRst.RecordCount
varStatus = SysCmd(acSysCmdInitMeter, "Exporting Records", lngRC)
lngStatus = 1
varStatus = SysCmd(acSysCmdUpdateMeter, lngStatus)
myRst.MoveFirst
While Not myRst.EOF
lngStatus = lngStatus + 1
varStatus = SysCmd(acSysCmdUpdateMeter, lngStatus)
myXLRst.AddNew
For i = 0 To myRst.Fields.Count - 1
myXLRst.Fields(i) = Nz(myRst.Fields(i))
Next i
myXLRst.Update
myRst.MoveNext
Wend
varStatus = SysCmd(acSysCmdRemoveMeter)
myXLRst.Close
Set myXLRst = Nothing
ExportToExcel = myRst.RecordCount
myRst.Close
Set myRst = Nothing
myDB.Close
Set myDB = Nothing
myXLDB.Close
Set myXLDB = Nothing
If bolMsgBoxWhenDone = True Then
MsgBox "Done!", _
vbInformation + vbOKOnly, _
"Export To Excel"
End If
End Function
'================================================= ====
Wayne Gillespie
Gosford NSW Australia
