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
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
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:
Select allOpen in new window
by: bigjokeyPosted on 2008-05-18 at 23:21:56ID: 21595516
So, are you saying that the following line will not allow more than 65,535 records? And you want to export the data into multiple sheets, and then calculate the totals of the columns from the data across the multiple sheets?
DoCmd.TransferSpreadsheet acExport, 8, "tblDtlBrOrder", ExportedFile, True, ""