• Home
 · 
• Miscellaneous
 · 
• export data to excel in multiple sheets if rows exceeds 65000

export data to excel in multiple sheets if rows exceeds 65000

export data to excel in multiple sheets if rows exceeds 65000

Rate export data to excel in multiple sheets if rows exceeds 65000

• 1
• 2
• 3
• 4
• 5

(1(1 Vote))

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