How to avoid the runtime error '1004' - To prevent possible loss of data, Microsoft Access cannot shift nonblank cells of the worksheet ?

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, ""
    Call ExportToExcels(ExportedFile, "OfficeNumber", "tblDtlBrOrder", "60000")         '<---- Call ExportToExcels
   
    'If isFileExist(ExportedFile) Then Calc_subtotals ExportedFile
    
    DoCmd.Hourglass False
End Sub
----------------------------------------------------
Private Sub ExportToExcels(filename As String, FieldToCount As String, TableToCount As String, NumberOfRecords As Long)
    Dim strSelect As String
    Dim strDelete 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
 
    strSelect = "Select top " & NumberOfRecords & " * from " & TableToCount
    strDelete = "delete from " & TableToCount & " where " & FieldToCount & " in(Select top " & NumberOfRecords & " " & FieldToCount & " from " & TableToCount & ")"
    
    Set cn = CurrentProject.Connection
    Set rs = New ADODB.Recordset
     
    Set db = CurrentDb
     
    recordtotal = DCount(FieldToCount, TableToCount)
    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 strSelect, 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
            Call GenerateTotals(sht, "B;C", "E")                '<---- Call GenerateTotals
            SheetNum = SheetNum + 1
            DoCmd.RunSQL (strDelete)
        rs.Close
        recordtotal = DCount(FieldToCount, TableToCount)
    Loop
     
    xlWB.Close (True)
    xl.Quit
    Set xl = Nothing
 
End Sub
-------------------------------------------
Private Sub GenerateTotals(objWorkSheet, strGroupColumns, strTotalColumns)
    Const FirstRow = 2
    Dim arrGroupColumns, arrTotalColumns, arrGroupColumnValues, arrTotalColumnValues
    Dim lngI, intJ, blnSameGroup
    Dim lngRowCount
    
    ' Store the column letters into arrays for use when referencing the cells of each row
    arrGroupColumns = Split(strGroupColumns, ";")
    arrTotalColumns = Split(strTotalColumns, ";")
    'Resize the Values arrays to store the current group values and Totals
    ReDim arrGroupColumnValues(UBound(arrGroupColumns))
    ReDim arrTotalColumnValues(UBound(arrTotalColumns))
    
    ' Start at 2nd row to ignore row headings
    lngRowCount = objWorkSheet.UsedRange.Rows.count
    lngI = FirstRow
    While lngI <= lngRowCount
        ' Determine if the Current row grouping values match the previous row grouping values
        'Default the same group variable to be true
        blnSameGroup = True
        For intJ = 0 To UBound(arrGroupColumns)
            blnSameGroup = blnSameGroup And (arrGroupColumnValues(intJ) = objWorkSheet.Range(arrGroupColumns(intJ) & lngI).Value)
            If Not blnSameGroup Then
                Exit For
            End If
        Next
        
        If blnSameGroup Then
            For intJ = 0 To UBound(arrTotalColumns)
                arrTotalColumnValues(intJ) = arrTotalColumnValues(intJ) + objWorkSheet.Range(arrTotalColumns(intJ) & lngI).Value
            Next
        Else
            ' Don't attempt to add a sub totals row if this is the first row
            If lngI > FirstRow Then
                ' Insert a new row above the current row number for inserting the subtotals
                objWorkSheet.Rows(lngI & ":" & lngI).Insert (xlDown)
                
                ' Write out the Sub Totals row, and then reset the grouping values and totals for the new group
                objWorkSheet.Range("A" & lngI).Value = "Sub Total:"
                For intJ = 0 To UBound(arrTotalColumns)
                    objWorkSheet.Range(arrTotalColumns(intJ) & lngI).Value = arrTotalColumnValues(intJ)
                Next
                
                ' increment the row counter so that it is now pointing to the row below the totals
                lngI = lngI + 1
                lngRowCount = lngRowCount + 1
            End If
                        
            ' Assign the new group values to the group values array
            For intJ = 0 To UBound(arrGroupColumns)
                arrGroupColumnValues(intJ) = objWorkSheet.Range(arrGroupColumns(intJ) & lngI).Value
            Next
            ' Assign the new group totals to the group totals array
            For intJ = 0 To UBound(arrTotalColumns)
                arrTotalColumnValues(intJ) = objWorkSheet.Range(arrTotalColumns(intJ) & lngI).Value
            Next
        End If
        lngI = lngI + 1
    Wend
    ' Once we get to the end of the used range, add a row that contains the final sub totals for that page
'    objWorkSheet.Range("A" & lngI).Value = "Sub Total:"
'    For intJ = 0 To UBound(arrTotalColumns)
'        objWorkSheet.Range(arrTotalColumns(intJ) & lngI).Value = arrTotalColumnValues(intJ)
'    Next
End Sub