by Aijaz A Khan (1 Submission)
Category: Miscellaneous
Compatability: VB 6.0
Difficulty: Unknown Difficulty
Originally Published: Mon 7th April 2008
Date Added: Mon 8th February 2021
Rating: 
(1 Votes)
export data to excel in multiple sheets if rows exceeds 65000
VBcoders
Public Sub ExportToWorksheet(rs As Recordset)
'takes a populated recordset
'exports the recordset to one or more new (named and numbered) worksheets
On Error GoTo Err_Handler
Dim objXLApp As New Excel.Application
Dim intSheetNumber As Integer
Dim objWS As Excel.Worksheet
Dim strSheetName As String
Dim fld As field
Dim intCol As Integer
Dim lngPage As Long
Dim rsReplica As New ADODB.Recordset
Dim lngRecCount As Long
objXLApp.Workbooks.Add
If rs.RecordCount > 65000 Then
lngRecCount = rs.RecordCount
intSheetNumber = 1
For lngPage = 1 To rs.PageCount
'adds a new sheet and name it
rs.AbsolutePage = lngPage
Set objWS = objXLApp.Worksheets.Add
strSheetName = "Spinner" & intSheetNumber
objWS.Name = strSheetName
'add the field names
For intCol = 0 To rs.Fields.count - 1
Set fld = rs.Fields(intCol)
objWS.Cells(1, intCol + 1) = fld.Name
With objXLApp
.Columns(Chr(intCol + 65) & ":" & Chr(intCol + 65)).Select
.Selection.NumberFormat = "@"
End With
Next intCol
objWS.Range(objWS.Cells(1, 1), objWS.Cells(1, rs.Fields.count)).Font.Bold = True
lRs = rs.GetString(adClipString, rs.PageSize)
strselconcate = "A" & 2
If lngRecCount > 65000 Then
strselconcate = strselconcate & ":" & Chr(rs.Fields.count + 64) & rs.PageSize + 1
lngRecCount = lngRecCount - 65000
Else
strselconcate = strselconcate & ":" & Chr(rs.Fields.count + 64) & lngRecCount + 1
End If
objXLApp.Range(strselconcate).Select
Clipboard.Clear
Clipboard.SetText (lRs)
objXLApp.ActiveSheet.Paste
objXLApp.Selection.CurrentRegion.Columns.AutoFit
objXLApp.Selection.CurrentRegion.Rows.AutoFit
'set the next sheet number
intSheetNumber = intSheetNumber + 1
Next
Else
'create and name worksheet
Set objWS = objXLApp.Worksheets.Add
objWS.Name = "Spinner1"
'copy to worksheet
'first the field names
For intCol = 0 To rs.Fields.count - 1
Set fld = rs.Fields(intCol)
objWS.Cells(1, intCol + 1) = fld.Name
Next intCol
'now the actual data
objWS.Range(objWS.Cells(1, 1), objWS.Cells(1, rs.Fields.count)).Font.Bold = True
objWS.Range("A2").CopyFromRecordset rs
End If
objXLApp.Visible = True
Err_Handler_Exit:
Screen.MousePointer = vbNormal
Exit Sub
Err_Handler:
Screen.MousePointer = vbNormal
MsgBox Err.Number & " - " & Err.Description & " - Sub ExportToWorksheet()"
Resume Err_Handler_Exit
End Sub