Recordset RecordCount returning Error 6 Overflow

[time2hike]

I have a command button that pulls an Adobe RecordSet and Exports the data to Excel. One of my users reports getting Error 6 Overflow when running the export for a particular criteria. I thought that it was because the recordset contained too many records, but when I look at the records for the criteria there is currently 44,461 records and Microsoft allows me to export these manually.

I stepped through the code and found that it fails on this line.

iRow = rst.RecordCount + 1

The code operates correctly for other criteria. Do you know of a solution to this issue?

This is the full code for the Command Button.

Private Sub cmd_XprtXls_Click()
On Error GoTo Err_cmd_XprtXls_Click
 
    Dim Conn As ADODB.Connection
    Dim stPath As String
    Dim rst As ADODB.Recordset
    Dim sSQL As String
    Dim stErrMsg As String
    Dim sSelect As String
    Dim sFrom As String
    Dim sGroupBy As String
    Dim sHaving As String
    Dim sOrder As String
    Dim DblYr As Double
    Dim DblMn As Double
    Dim sPM As String
    Dim sROGT As String
    Dim stPrjt As String
    Dim sSbprjtGrp As String
    Dim stSbprjt As String
    Dim stOrg As String
    Dim stAct As String
    Dim xlApp As Object
    Dim xlWb As Object
    Dim xlWs As Object
    Dim acRng As Variant
    Dim iRow As Integer
 
    DoCmd.Hourglass True
'    Debug.Print Me.Name & " Start Export: " & Now()
 
    stErrMsg = ""
    If IsNull(Me.cmb_ExpYr.Value) Then
        stErrMsg = stErrMsg & vbCrLf & "Year"
    End If
    If IsNull(Me.cmb_ExpMnth.Value) Then
        stErrMsg = stErrMsg & vbCrLf & "Month"
    End If
 
'12/15/14 Requirements Changed per PMaC development group
    If Not IsNull(Me.cmb_PM) And IsNull(Me.cmbRptOwnerGrpTitle) Then
        strErrMsg = strErrMsg & vbCrLf & "Favorites is required when PM/Report Owner is selected"
    End If
 
    If IsNull(Me.cmb_ProjectID.Value) Then
        stErrMsg = stErrMsg & vbCrLf & "Project"
    End If
 
    If stErrMsg <> "" Then
        MsgBox "Please select the required information." & vbCrLf & stErrMsg, vbExclamation + vbOKOnly, "Missing Information"
        DoCmd.Hourglass False
        Exit Sub
    End If
 
    'Set the query parameter values
    DblYr = Me.cmb_ExpYr.Value
    DblMn = Me.cmb_ExpMnth.Value
    stPrjt = Me.cmb_ProjectID
    ' 12/15/14
    If IsNull(Me.cmb_PM) Then
        sPM = "'%'"
        sROGT = "%"
    Else
        sPM = Me.cmb_PM
        sROGT = Me.cmbRptOwnerGrpTitle
    End If
 
    If IsNull(Me.cmbSbprjtGrp.Value) Then
        sSbprjtGrp = "%"
    Else
        sSbprjtGrp = Me.cmbSbprjtGrp.Value
    End If
    If IsNull(Me.cmb_SubprojectID) Then
        stSbprjt = "%"
    Else
        stSbprjt = Me.cmb_SubprojectID
    End If
    If IsNull(Me.cmb_ActivityID) Then
        stAct = "%"
    Else
        stAct = Me.cmb_ActivityID
    End If
    If IsNull(Me.cmb_OrgGrp) Then
        stOrg = "%"
    Else
        stOrg = Me.cmb_OrgGrp
    End If
 
    sSelect = "SELECT [LTD]![ProjectDescription] AS [Project ID - Description]" _
        & ", [LTD]![SUBPROJECTDESCRIPTION] AS [Subproject ID - Description]" _
        & ", [LTD]![ActivityDESCR] AS [Activity ID - Description]" _
        & ", [LTD]![PROJECT_TO] AS [Funding Project ID - Description]" _
        & ", [LTD]![SUBPROJECT_TO] AS [Funding Subproject ID - Description]" _
        & ", [LTD]![Activity_To] AS [Funding Activity ID - Description]" _
        & ", LTD.VndrEmpName AS Name, [LTD]![Phase] & ' - ' & [tblPhaseDescr]![Description] AS Phase" _
        & ", LTD.Organization AS [Org - Description]" _
        & ", LTD.OrgGrp AS [Org Group]" _
        & ", LTD.Labor AS [Account Group]" _
        & ", LTD.FiscalYear AS [Year]" _
        & ", LTD.AccountingPeriod AS [Month]" _
        & ", Sum(IIf([LTD]![FiscalYear]= " & DblYr & " And [LTD]![AccountingPeriod]= " & DblMn & ",[LTD]![EXPENDITURES],0)) AS [Current Month Amt]" _
        & ", Sum(IIf([LTD]![FiscalYear]= " & DblYr & " And [LTD]![AccountingPeriod]<= " & DblMn & ",[LTD]![EXPENDITURES],0)) AS [Year to Date Amt]" _
        & ", Sum(IIf([LTD]![FiscalYear]= " & DblYr & " And [LTD]![AccountingPeriod]<= " & DblMn & ",[LTD]![EXPENDITURES],IIf([LTD]![FiscalYear]<= " & DblYr & ",[LTD]![EXPENDITURES],0))) AS [Life To Date Amt]" _
        & ", Sum(IIf([LTD]![FiscalYear]= " & DblYr & " And [LTD]![AccountingPeriod]= " & DblMn & ",[LTD]![Hours],0)) AS [Current Month Hrs]" _
        & ", Sum(IIf([LTD]![FiscalYear]= " & DblYr & " And [LTD]![AccountingPeriod]<= " & DblMn & ",[LTD]![Hours],0)) AS [Year to Date Hrs]" _
        & ", Sum(IIf([LTD]![FiscalYear]= " & DblYr & " And [LTD]![AccountingPeriod]<= " & DblMn & ",[LTD]![Hours],IIf([LTD]![FiscalYear]<" & DblYr & ",[LTD]![Hours],0))) AS [Life To Date Hrs]"
 
    sFrom = "FROM (SELECT Trim([zqselMngrSbprjtRptGrpSbprjtFltr_Exp]![SubprojectID]) AS SubprojectID" _
                        & " FROM zqselMngrSbprjtRptGrpSbprjtFltr_Exp" _
                        & " WHERE (((IIf([zqselMngrSbprjtRptGrpSbprjtFltr_Exp]![GROUPINGCODE] Is Null,'ZZZ',[zqselMngrSbprjtRptGrpSbprjtFltr_Exp]![GROUPINGCODE]) ALike '" & sSbprjtGrp & "'))" _
                        & " AND ((IIf([zqselMngrSbprjtRptGrpSbprjtFltr_Exp]![RPTGRPTITLE] Is Null,'ZZZ',[zqselMngrSbprjtRptGrpSbprjtFltr_Exp]![RPTGRPTITLE]) ALike '" & sROGT & "'))" _
                        & " AND ((IIf([zqselMngrSbprjtRptGrpSbprjtFltr_Exp]![RptOwnerID] Is Null,0,[zqselMngrSbprjtRptGrpSbprjtFltr_Exp]![RptOwnerID])) ALike " & sPM & ")" _
                        & " AND ((zqselMngrSbprjtRptGrpSbprjtFltr_Exp.PROJECTID ALike '" & stPrjt & "')))" _
                        & " GROUP BY Trim([zqselMngrSbprjtRptGrpSbprjtFltr_Exp]![SubprojectID])" _
                        & " HAVING (((Trim([zqselMngrSbprjtRptGrpSbprjtFltr_Exp]![SubprojectID])) ALike '" & stSbprjt & "'))) AS qrptSbPrjtLTDPrgmCMYTDLTDSbprjtFltrd" _
                & " LEFT JOIN (tblPrjtLTDExpndRptBase AS LTD " _
                & " LEFT JOIN tblPhaseDescr ON LTD.Phase = tblPhaseDescr.PHASE)" _
            & " ON qrptSbPrjtLTDPrgmCMYTDLTDSbprjtFltrd.SubprojectID = LTD.SUBPROJECTID"
 
    sGroupBy = " GROUP BY [LTD]![ProjectDescription]" _
        & ", [LTD]![SUBPROJECTDESCRIPTION]" _
        & ", [LTD]![ActivityDESCR]" _
        & ", [LTD]![PROJECT_TO]" _
        & ", [LTD]![SUBPROJECT_TO]" _
        & ", [LTD]![Activity_To]" _
        & ", LTD.VndrEmpName" _
        & ", [LTD]![Phase] & ' - ' & [tblPhaseDescr]![Description]" _
        & ", LTD.Organization" _
        & ", LTD.OrgGrp" _
        & ", LTD.Labor" _
        & ", LTD.FiscalYear" _
        & ", LTD.AccountingPeriod" _
        & ", LTD.ACTIVITYID"
 
    sHaving = " HAVING (((LTD.OrgGrp) ALike """ & stOrg & """) AND ((LTD.FiscalYear)=" & DblYr & ") AND ((LTD.AccountingPeriod)<=" & DblMn & ")" _
                    & " AND ((LTD.ACTIVITYID) ALike '" & stAct & "') AND ((Sum(LTD.Expenditures))<>0)) " _
                & " OR (((LTD.OrgGrp) ALike """ & stOrg & """) AND ((LTD.FiscalYear)<" & DblYr & ") AND ((LTD.ACTIVITYID) ALike '" & stAct & "') AND ((Sum(LTD.Expenditures))<>0))"
 
    sOrder = " ORDER BY Sum(IIf([LTD]![FiscalYear]= " & DblYr & " And [LTD]![AccountingPeriod]= " & DblMn & ",[LTD]![EXPENDITURES],0))" _
        & ", Sum(IIf([LTD]![FiscalYear]= " & DblYr & " And [LTD]![AccountingPeriod]<= " & DblMn & ",[LTD]![EXPENDITURES],0))"
 
    ' Open recordset
    Set rst = New ADODB.Recordset
    sSQL = sSelect & vbCrLf & sFrom & vbCrLf & sGroupBy & vbCrLf & sHaving & ";"
'    Debug.Print sSQL
    rst.Open sSQL, CurrentProject.Connection, adOpenStatic, adLockReadOnly
    If rst.BOF And rst.EOF Then
        MsgBox "No Data Available to Export", vbOKOnly, "No Data"
        DoCmd.Hourglass False
        Exit Sub
    End If
    rst.MoveLast
 
'    Debug.Print rst.RecordCount
    iRow = rst.RecordCount + 1
 
    ' Create an instance of Excel and add a workbook
    Set xlApp = New Excel.Application
    Set xlWb = xlApp.Workbooks.Add
    Set xlWs = xlWb.Worksheets("Sheet1")
 
    ' Display Excel and give user control of Excel's lifetime
    xlApp.Visible = True
    xlApp.UserControl = True
 
    ' Copy field names to the first row of the worksheet
    fldCount = rst.Fields.Count
    For iCol = 1 To fldCount
        xlWs.Cells(1, iCol).Value = rst.Fields(iCol - 1).Name
    Next
 
    rst.MoveFirst
 
    ' Copy the recordset to the worksheet, starting in cell A2
    xlWs.Range("A2", "XFD" & iRow).CopyFromRecordset rst
 
    ' Auto-fit the column widths and row heights
    xlApp.Selection.CurrentRegion.Columns.AutoFit
    xlApp.Selection.CurrentRegion.Rows.AutoFit
    xlWs.Range("N2", "P" & iRow).NumberFormat = "$#,###;($#,###)[Red];-;-" 'Format the Amounts
    xlWs.Range("Q2", "S" & iRow).NumberFormat = "#,###;(#,###)[Red];-;-" 'Format the Hours
 
    ' Close ADO objects
    rst.Close
'    conn.Close
    Set rst = Nothing
'    Set conn = Nothing
 
    ' Release Excel references
    Set xlWs = Nothing
    Set xlWb = Nothing
 
    Set xlApp = Nothing
    DoCmd.Hourglass False
 
Exit_cmd_XprtXls_Click:
    Exit Sub
Err_cmd_XprtXls_Click:
    DoCmd.Hourglass False
    If Err.Number = 6 Then
        MsgBox "The dataset you have choosen to export is too large.  Use additional filters to limit the dataset. "
    Else
        MsgBox "Error " & Err.Number & " (" & Err.Description & ")"
        DoCmd.SetWarnings True
        DoCmd.Hourglass False
    End If
        Resume Exit_cmd_XprtXls_Click
End Sub

Thank you for looking at this.

[Rabbit]

The range of an integer in VBA is -32,768 to 32,767.
https://msdn.microsoft.com/en-us/lib...(v=VS.60).aspx

[time2hike]

Thank you! That makes sense.