Option Compare Database
Option Explicit
Public Function SQL_TableX() As String
[COLOR=seagreen]'Query string to retrieve al fields and records from TableX
'TableX should be substituted with you table name
[/COLOR]SQL_TableX = "Select * from TableX"
End Function
[COLOR=seagreen]'Set reference to Microsoft Excel xx Object Library
'Set reference to Microsoft ActiveX Data Objects 2.x Library
'Free to use, coded by MIO-Software Netherlands
[/COLOR]Public Sub CreateExcel()
Dim oCn As New ADODB.Connection
Dim oRs As New ADODB.Recordset
Dim oExcelApp As New Excel.Application
Dim oExcelWB As New Excel.Workbook
Dim oExcelSht As Excel.Worksheet
Dim sWorkbookName As String
Dim sSheetName As String
Dim arrAllRecords() As Variant
Dim arrSubRecords() As Variant
Dim lRecNo As Long
Dim lRecNoSub As Long
Dim lMaxRecPerSheet As Long
Dim lRunningTot As Long
Dim iNumbSheets As Integer
Dim iSheetCnt As Integer
Dim iFldCnt As Integer
Dim i As Integer
Set oCn = CurrentProject.Connection
[COLOR=seagreen]'Here type the maximum rows you want per sheet
[/COLOR][COLOR=sienna][B]lMaxRecPerSheet = 1000[/B][/COLOR]
With oRs
.Open SQL_TableX, oCn, adOpenStatic, adLockReadOnly
arrAllRecords = oRs.GetRows()
iFldCnt = .Fields.Count - 1
.Close
End With
Set oRs = Nothing
'Calculate number of sheets needed
iNumbSheets = Round((UBound(arrAllRecords, 2) / lMaxRecPerSheet) + 0.5)
[COLOR=seagreen] 'you can skip this, it's just a security to avoid overstack, but better don't skip
[/COLOR] If iNumbSheets > 255 Then
MsgBox "Can't create more then 255 sheets", vbExclamation
Exit Sub
End If
'create Excel object
[COLOR=seagreen]'Here comes your path and workbookname
[/COLOR][B][COLOR=sienna]sWorkbookName = "M:\CreateExcel\MyExcelBook"[/COLOR][/B]
With oExcelApp
lRunningTot = 0
iSheetCnt = 1
'Create a new workbook
Set oExcelWB = Workbooks.Add
With oExcelWB
For lRecNo = lRunningTot To UBound(arrAllRecords, 2)
[COLOR=seagreen]'If last sheet, dimension arrSubRecords to the number of left records
[/COLOR] If iSheetCnt = iNumbSheets Then
ReDim arrSubRecords(iFldCnt, UBound(arrAllRecords, 2) - lRunningTot)
Else
ReDim arrSubRecords(iFldCnt, lMaxRecPerSheet - 1)
End If
[COLOR=seagreen] 'Fill array subrecords
[/COLOR] For lRecNoSub = 0 To UBound(arrSubRecords, 2)
For i = 0 To iFldCnt
arrSubRecords(i, lRecNoSub) = arrAllRecords(i, lRecNoSub + lRunningTot)
Next i
Next lRecNoSub
[COLOR=seagreen] 'When subrecords complete, create a workhsheet for the records
[/COLOR] sSheetName = "Sheet " & iSheetCnt & " of " & iNumbSheets
Set oExcelSht = .Worksheets().Add
'Copy array to new sheet
With oExcelSht
.Name = sSheetName
.Cells(1, 1).Resize(UBound(arrSubRecords, 2) + 1, UBound(arrSubRecords, 1) + 1).Value = _
oExcelApp.WorksheetFunction.Transpose(arrSubRecords)
End With
iSheetCnt = iSheetCnt + 1
lRunningTot = lRecNoSub + lRunningTot
lRecNo = lRunningTot - 1
[COLOR=seagreen] 'Move one to next chunck
[/COLOR] Next lRecNo
End With
oExcelWB.SaveAs sWorkbookName
[COLOR=seagreen] 'Destroy object
[/COLOR] .Quit
Erase arrSubRecords
Erase arrAllRecords
End With
End Sub
ffice
></o
