How to create the use of multiple worksheets using Excel VBA ?

I am developing an Access application with Excel VBA using Access 2003 as the front end and SQL Server as the back end database.

I use the following Attached Code Snippet containing 2 functions:
a) UDLIntToExcel()
b) ExportToExcels(filename As String)
to write out to an Excel file using Multiple Worksheets from an Access table.

Do you know how I could modify the following 2 functions
a) BranchDetailAll()
b) Calc_subtotals(filename)
using logic similar to the above function ExportToExcels(filename As String)
to write out to an Excel file using Mutiple Worksheets from an Access table

The problem with the following 2 functions is that they cannot handle > 65,535 records where Multiple Worksheets need to be used.

Private Sub BranchDetailAll()
    Dim cnn As ADODB.Connection
    Dim ExportedFile As String
    Dim strNextFile As String
    Dim rstQueryFS As ADODB.Recordset
    Dim objXL As Excel.Application
    Dim objWS As Excel.Worksheet
    Dim fld As ADODB.Field
    Dim intCol As Integer
    Dim intRow As Integer
    Dim strSQL As String
    Dim intBonds As Integer
    Dim com As ADODB.Command
    Dim P1 As New Parameter
    Dim intReport As Integer
    Const strTable = "tblDtlBranchAll"
    Set cnn = CurrentProject.Connection
    Dim cn As ADODB.Recordset
   
    Set cn = New ADODB.Recordset
   
    cn.ActiveConnection = CurrentProject.Connection
    cn.CursorType = adOpenStatic
    cn.CursorLocation = adUseServer
    cn.LockType = adLockReadOnly

    strSQL = "If  Exists(SELECT * FROM dbo.SYSOBJECTS WHERE NAME = 'tblDtlBranchAll' AND TYPE = 'U') DROP TABLE tblDtlBranchAll"
   
    cn.Open strSQL
   
    strSQL = "If  Exists(SELECT * FROM dbo.SYSOBJECTS WHERE NAME = 'tblDtlBrOrder' AND TYPE = 'U') DROP TABLE tblDtlBrOrder"
   
    cn.Open strSQL
       
    DoCmd.Hourglass True
       
    Set com = New ADODB.Command
    With com
       .CommandType = adCmdStoredProc
       .CommandText = "dbo.procNumberOfAccounts"
        Set .ActiveConnection = CurrentProject.Connection
       .Execute
    End With
   
    Set com = New ADODB.Command
    With com
       .CommandType = adCmdStoredProc
       .CommandText = "dbo.procDeleteBrAllRpt"
        Set .ActiveConnection = CurrentProject.Connection
       .Execute
    End With
   
    Set com = New ADODB.Command
    With com
       .CommandType = adCmdStoredProc
       .CommandText = "dbo.procDetailBranchAll"
       .Parameters.Append .CreateParameter("@Branch", adVarChar, adParamInput, 4, strBranch)
       Set .ActiveConnection = CurrentProject.Connection
       .Execute
    End With
   
    strSQL = "select OfficeNumber, CustomerNumber,DateRange,[Property Type],MarketValue into dbo.tblDtlBrOrder From dbo.tblDtlBranchAll order by DateRange Asc, CustomerNumber Asc, MarketValue Desc "
    cn.Open strSQL
   
    ExportedFile = "\\nydfs1\root\lib\CONTROLLERS\IIG\CASH_CONTROL\ccshared\AbandonedProperty\UDL\Access\Reconcile\DTLBRANCHALL" & "_" & intYearSP & "_" & Format(Now, "mmddhhnnss") & ".XLS"
    DoCmd.TransferSpreadsheet acExport, 8, "tblDtlBrOrder", ExportedFile, True, ""
   
    If isFileExist(ExportedFile) Then Calc_subtotals ExportedFile
   
    DoCmd.Hourglass False
End Sub

Private Sub Calc_subtotals(filename)
Dim str As String
Dim lastrow As Long
Dim i As Long
Dim rng As Range
Dim celle As Range
Dim str1 As String
Dim str2 As String
Dim rowe As Long
Dim temp As Double
Dim xlApp As Excel.Application
Dim xlWB As Excel.Workbook
Dim xlWS As Excel.Worksheet
Set xlApp = New Excel.Application
xlApp.Visible = True
Set xlWB = xlApp.Workbooks.Open(filename)
Set xlWS = xlWB.Sheets(1)
xlApp.ScreenUpdating = False
rowe = 2
str1 = "A"
str2 = "E"
With xlWS
    Set rng = .Range(.Cells(rowe, str1), .Cells(.Cells.Rows.count, str2).End(xlUp))
End With
 
rng.Sort Key1:=xlWS.Range("C2"), Order1:=xlAscending, Key2:=xlWS.Range("B2") _
        , Order2:=xlAscending, Key3:=xlWS.Range("E2"), Order3:=xlAscending, Header:= _
        xlNo, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal, DataOption2:=xlSortNormal, DataOption3:= _
        xlSortNormal
str = "B"
With xlWS
    lastrow = .Cells(.Cells.Rows.count, str).End(xlUp).Offset(1, 0).Row
 
For i = lastrow To 3 Step -1
    If .Cells(i, "B") <> .Cells(i - 1, "B") Then
        .Rows(i).Insert Shift:=xlDown
    End If
Next i
 
str = "B"
lastrow = .Cells(.Cells.Rows.count, str).End(xlUp).Offset(1, 0).Row
 
temp = 0
For i = 2 To lastrow
    temp = temp + Cells(i, 5)
    If Cells(i, 5) = "" Then
        Cells(i, 6) = temp
        temp = 0
        Cells(i, 1) = "Sub-total"
    End If
Next i
 
End With
 
xlWS.Columns("F:F").NumberFormat = "#,##0.00"
 
xlApp.ScreenUpdating = True
 
End Sub
Start Free Trial

1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:
27:
28:
29:
30:
31:
32:
33:
34:
35:
36:
37:
38:
39:
40:
41:
42:
43:
44:
45:
46:
47:
48:
49:
50:
51:
52:
53:
54:
55:
56:
57:
58:
59:
60:
61:
62:
63:
64:
65:
66:
67:
68:
69:
70:
71:
72:
73:
74:
75:
76:
77:
78:
79:
80:
81:
82:
83:
84:
85:
86:
87:
88:
89:
90:
91:
92:
93:
94:
95:
96:
97:
98:
99:
100:
101:
102:
103:
104:
105:
106:

Private Sub UDLIntToExcel()
    Dim cn As ADODB.Recordset
    Dim ExportedFile As String
    Dim ImportedFile As String
    Dim strNextFile As String
    Dim rstQueryFS As ADODB.Recordset
    Dim objXL As Excel.Application
    Dim objWS As Excel.Worksheet
    Dim fld As ADODB.Field
    Dim intCol As Integer
    Dim intRow As Integer
    Dim strSQL As String
    Dim intBonds As Integer
    Dim com As ADODB.Command
    Dim P1 As New Parameter
    Dim str_sql As String
    Dim filename As String
    Dim strAccessPath2 As String
              
    str_sql = "If  Exists(SELECT * FROM dbo.SYSOBJECTS WHERE NAME = 'tblRemedInternal' AND TYPE = 'U') DROP TABLE tblRemedInternal"
    DoCmd.RunSQL (str_sql)
    
    Set cn = New ADODB.Recordset
    
    cn.ActiveConnection = CurrentProject.Connection
    cn.CursorType = adOpenStatic
    cn.CursorLocation = adUseServer
    cn.LockType = adLockReadOnly
               
    DoCmd.Hourglass True
    Set com = New ADODB.Command
    With com
       .CommandTimeout = 95
       .CommandType = adCmdStoredProc
       .CommandText = "dbo.procRemedInternal2"
       .ActiveConnection = CurrentProject.Connection
       Set rstQueryFS = .Execute
    End With
              
    ExportedFile = strAccessPath0 & strAccessPath7 & "INTERNAL" & "_" & intYearSP & "_" & Format(Now, "mmddhhnnss") & ".XLS"
    
    ExportToExcels ExportedFile
    
    Beep
    MsgBox "Internal has been exported to Excel", vbOKOnly, ""
      
    If isFileExist(ExportedFile) Then StartDocInternalXLS ExportedFile
    DoCmd.Hourglass False
End Sub
 
Private Sub ExportToExcels(filename As String)
Dim str_sql As String
Dim cn As ADODB.Connection
Dim xl As Excel.Application
Dim xlWB As Excel.Workbook
Dim sht As Excel.Worksheet, rng As Excel.Range
Dim db As DAO.Database, rs As ADODB.Recordset
Dim recordtotal As Long
Dim SheetNum As Long
Dim dest As Range
Dim Counter As Long
Dim Source As Workbook
 
 
Set cn = CurrentProject.Connection
Set rs = New ADODB.Recordset
 
Set db = CurrentDb
 
recordtotal = DCount("ProdID", "tblRemedInternal")
Set xl = CreateObject("Excel.Application")
 
Set xlWB = xl.Workbooks.Add ' Add a new workbook
xlWB.SaveAs filename ' Save the new workbook as "filename"
Set xlWB = xl.Workbooks.Open(filename)  '<--Your Excel File Here
 
 
xl.Visible = True
SheetNum = 1
Do While recordtotal > 0
    rs.Open "Select top 60000 * from tblRemedInternal", cn, 2, 2
    If rs.EOF Then Exit Sub
    rs.MoveFirst
        Set sht = Nothing
        On Error Resume Next
        Set sht = xlWB.Worksheets("Sheet" & SheetNum)
        On Error GoTo 0
        
        If sht Is Nothing Then
        xlWB.Worksheets.Add After:=Worksheets(Worksheets.count)
            Set sht = ActiveSheet
            sht.Name = "Sheet" & SheetNum
        End If
        sht.Range("A1").CopyFromRecordset rs
        SheetNum = SheetNum + 1
        str_sql = "delete from tblRemedInternal where ProdID in(Select top 60000 ProdID from tblRemedInternal)"
        DoCmd.RunSQL (str_sql)
    rs.Close
    recordtotal = DCount("ProdID", "tblRemedInternal")
Loop
 
xlWB.Close (True)
xl.Quit
Set xl = Nothing
 
End Sub