MaxRows 65536 in a sheet - A Code Snippet

[Ravee Srinivasan]

Hi Everybody,
Just a code snippet to handle the MaxRows (65536) in a
sheet while copying a recordset object on to a workbook.
It dynamically adds a sheet if required to handle any
number of rows
Its just that I have been researching this problem (not a
bug ) for some time, I thought some one might need a
reference.

Thanks
Ravee.

'-------------------------------------
Sub ExcelExport()
Dim sFileName As String
Dim lRow As Long
Dim lCol As Long
Dim lPage As Long
Dim lFields As Long
Dim lRecs As Long
Dim lMaxRow As Long
Dim oField As Object
Dim iScale As Integer
Dim sScale As String
Dim sOutputType As Integer
Dim vArray As Variant
Dim vBookmark As Variant
On Error GoTo Err_Handl
lMaxRow = 65535
' Choose a output type here
sOutputType = -4346 'defaults to .xls
sFileName = "C:\TEMP\"
On Error Resume Next
Set oXl = GetObject(, "Excel.Application") 'look for a
running copy of Excel
If Err.Number <> 0 Then 'If Excel is not running then
' Set oXl = CreateObject("Excel.Application") 'run
it
Set oXl = New Excel.Application 'run it
End If
On Error GoTo Err_Handl:
oXl.DisplayAlerts = False
Set oXLWrkBk = oXl.Workbooks.Add
Set oXlSheet = oXLWrkBk.ActiveSheet
If oRS.RecordCount > lMaxRow Then
lPage = 1
oRS.MoveFirst
While oRS.EOF = False
vBookmark = oRS.Bookmark
vArray = oRS.GetRows(lMaxRow, vBookmark)
If lPage > oXLWrkBk.Sheets.Count Then
'Set oXlSheet = oXLWrkBk.Sheets.Add(After:=
(lPage - 1), Type:=xlWorksheet)
oXLWrkBk.Sheets.Add
After:=oXLWrkBk.Worksheets(oXLWrkBk.Sheets.Count),
Type:=xlWorksheet
End If
Set oXlSheet = oXLWrkBk.Sheets(lPage)
oXlSheet.Activate
lCol = 1
For Each oField In oRS.Fields
oXlSheet.Columns(lCol).Select
Select Case oField.Type
Case adInteger, adSmallInt, adBigInt,
adTinyInt, adUnsignedBigInt, _
adUnsignedInt, adUnsignedSmallInt,
adUnsignedTinyInt
oXl.Selection.NumberFormat = "#,##0"
Case adCurrency
oXl.Selection.NumberFormat
= "$#,###,##0.00"
Case adDate, adDBTimeStamp, adDBDate,
adDBTime
oXl.Selection.NumberFormat
= "mm/dd/yyyy hh:mm AM/PM"
Case adDecimal, adNumeric, adDouble,
adSingle
sScale = "#,##0."
If oField.NumericScale > 0 Then
For iScale = 1 To
oField.NumericScale
sScale = sScale & "0"
Next
Else
sScale = "#,##0"
End If
oXl.Selection.NumberFormat = sScale
Case Else
oXl.Selection.NumberFormat = "@"
oXl.Selection.HorizontalAlignment =
xlLeft
End Select
oXlSheet.Cells(1, lCol).Value = oField.Name
oXlSheet.Cells(1, lCol).Font.Bold = True
lCol = lCol + 1
Next oField
lFields = oRS.Fields.Count
lRecs = UBound(vArray, 2) + 1 '+ 1 since 0-
based array
For lCol = 0 To lFields - 1
For lRow = 0 To lRecs - 1
If IsDate(vArray(lCol, lRow)) Then '
Take care of Date fields
vArray(lCol, lRow) = Format(vArray
(lCol, lRow))
ElseIf IsArray(vArray(lCol, lRow))
Then ' Take care of OLE object fields or array fields
vArray(lCol, lRow) = "Array Field"
End If
Next lRow 'next record
Next lCol 'next field
oXlSheet.Cells(2, 1).Resize(lRecs,
lFields).Value = TransposeDim(vArray)
'For each sheet
oXl.Selection.CurrentRegion.AutoFilter
oXl.Selection.CurrentRegion.Columns.AutoFit
oXl.Selection.CurrentRegion.Rows.AutoFit
lPage = lPage + 1
Wend 'While oRS.EOF = True
Else 'If oRS.RecordCount > 65535 Then
' Meant to work in Excel 2000; use the above logic
for older versions
oXlSheet.Range("A2").CopyFromRecordset oRS
End If 'If oRS.RecordCount > 65535 Then
oXLWrkBk.Sheets(1).Activate
Set oXlSheet = oXLWrkBk.ActiveSheet
oXlSheet.Cells(1, 1).Select
oXlSheet.SaveAs sFileName, sOutputType
oXlSheet.Application.Quit
DoEvents
GoTo Exit_Handl:
Err_Handl:
MsgBox Err.Description
Exit_Handl:
oXlSheet.Application.Quit
Set oField = Nothing
Set oXlSheet = Nothing
Set oXLWrkBk = Nothing
Set oXl = Nothing
End Sub
Function TransposeDim(v As Variant) As Variant
' Custom Function to Transpose a 0-based array (v)
Dim X As Long, Y As Long, Xupper As Long, Yupper As
Long
Dim tempArray As Variant
Xupper = UBound(v, 2)
Yupper = UBound(v, 1)
ReDim tempArray(Xupper, Yupper)
For X = 0 To Xupper
For Y = 0 To Yupper
tempArray(X, Y) = v(Y, X)
Next Y
Next X
TransposeDim = tempArray
End Function