Mengimport Data ke Excel

different version of export to excel writes data in multiple sheets if rows exceeds 65000
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