Appending data from Access to Excel

Sorry John for not getting back to you sooner.

Try replacing

oExcelWrkSht.Cells(lStartRow + 1, lStartCol).CopyFromRecordset rs

Select allOpen in new window

with (untested aircode)

lLastRow = oExcelWrkSht.Cells(oExcelWrkSht.Rows.Count, 1).End(xlUp).Row
oExcelWrkSht.Cells(lLastRow + 1, lStartCol).CopyFromRecordset rs

Select allOpen in new window

Daniel,

No worries.  You answered my previous question so it was probably best to ask a new one being that I am asking how to append to the file.

I receive the following error:
Error Number 1004
Application-defined or object-defined error

I am thinking it is the lLastRow needs to be defined as:

Optional ByVal lLastRow As Long, _ 

Select allOpen in new window

What are your thoughts?

John

Defining it didn't help either.

So I have been thinking about this.  If I am defining the lStartCol and lStartRow as 2 and 7 then the last row is already past to the function.
But if I can make them row subject to change then it might work.  I am going to try that today,

Any thoughts on this would be greatly appreciated.

V/r
John

So Here is what I did to get it work:
I added a field to the form labeled txtLastRow

The user can enter the last row used if they are appending to the current spreadsheet

The function look to see if that field is empty or not.  If it is, it operates as intended.  If it holds data, then the lStartRow is changed from 8 to the txtLastRow.  The header is then skipped over if the txtLastRow has information in it.

Below is the modified function:

Function ExportRecordset2XLS(ByVal rs As DAO.Recordset, _
                             Optional ByVal sFile As String, _
                             Optional ByVal sWrkSht As String = "Hardware", _
                             Optional ByVal lStartCol As Long = 2, _
                             Optional ByVal lStartRow As Long, _
                             Optional ByVal lLastRow As Long, _
                             Optional bFitCols As Boolean = True, _
                             Optional bFreezePanes As Boolean = True, _
                             Optional bAutoFilter As Boolean = False)
    '#Const EarlyBind = True    'Use Early Binding, Req. Reference Library
    #Const EarlyBind = False    'Use Late Binding
    #If EarlyBind = True Then
        'Early Binding Declarations
        Dim oWSHShell
        Dim oExcel            As Excel.Application
        Dim oExcelWrkBk       As Excel.Workbook
        Dim oExcelWrkSht      As Excel.WorkSheet
    #Else
        'Late Binding Declaration/Constants
        Dim oWSHShell
        Dim oExcel            As Object
        Dim oExcelWrkBk       As Object
        Dim oExcelWrkSht      As Object
        Const xlCenter = -4108
    #End If
    Dim bExcelOpened          As Boolean
    Dim iCols                 As Integer
    Dim lWrkBk                As Long
 
    Set oWSHShell = CreateObject("WScript.Shell")
    sFile = oWSHShell.SpecialFolders("Desktop") & "\COMPASS\HWSWList_Template.xlsm"
    
    If IsNull(Forms![Form - eMASS Report]![txtLastRow]) Then
    lStartRow = 7
    Else:
    lStartRow = Forms![Form - eMASS Report]![txtLastRow]
    End If

    'Start Excel
    On Error Resume Next
    Set oExcel = GetObject(, "Excel.Application")    'Bind to existing instance of Excel
 
    If Err.Number <> 0 Then    'Could not get instance of Excel, so create a new one
        Err.Clear
        On Error GoTo Error_Handler
        Set oExcel = CreateObject("Excel.Application")
        bExcelOpened = False
    Else    'Excel was already running
        bExcelOpened = True
    End If
    On Error GoTo Error_Handler
 
    oExcel.ScreenUpdating = False
    oExcel.Visible = False   'Keep Excel hidden until we are done with our manipulation
 
    If sFile <> "" Then
        Set oExcelWrkBk = oExcel.Workbooks.Open(sFile)    'Start a new workbook
        On Error Resume Next
        lWrkBk = Len(oExcelWrkBk.Sheets(sWrkSht).Name)
        If Err.Number <> 0 Then
            oExcelWrkBk.Worksheets.Add.Name = sWrkSht
            Err.Clear
        End If
        On Error GoTo Error_Handler
        Set oExcelWrkSht = oExcelWrkBk.Sheets(sWrkSht)
        oExcelWrkSht.Activate
    Else
        Set oExcelWrkBk = oExcel.Workbooks.Add()    'Start a new workbook
        Set oExcelWrkSht = oExcelWrkBk.Sheets(1)
        If sWrkSht <> "" Then
            oExcelWrkSht.Name = sWrkSht
        End If
    End If
 
    With rs
        If .RecordCount <> 0 Then
            .MoveFirst    'This is req'd, had some strange behavior in certain instances without it!
            If IsNull(Forms![Form - eMASS Report]![txtLastRow]) Then
            'Build our Header
            '****************
            For iCols = 0 To rs.Fields.Count - 1
                oExcelWrkSht.Cells(lStartRow, lStartCol + iCols).Value = rs.Fields(iCols).Name
            Next
            'Format the header
            With oExcelWrkSht.Range(oExcelWrkSht.Cells(lStartRow, lStartCol), _
                                    oExcelWrkSht.Cells(lStartRow, lStartCol + iCols - 1))
                .Font.Bold = True
                .Font.ColorIndex = 2
                .Interior.ColorIndex = 1
                .HorizontalAlignment = xlCenter
            End With
            Else:
            GoTo XLSCopy
            End If
            
XLSCopy:
            'Copy the data from our query into Excel
            '***************************************
            oExcelWrkSht.Cells(lStartRow + 1, lStartCol).CopyFromRecordset rs
            'lLastRow = sWrkSht.Cells(sWrkSht.Rows.Count, 1).End(xlUp).Row
            
            'Some formatting to make things pretty!
            '**************************************
            'Freeze pane
            If bFreezePanes = True Then
                oExcelWrkSht.Cells(lStartRow + 1, 1).Select
                oExcel.ActiveWindow.FreezePanes = True
            End If
            'AutoFilter
            If bAutoFilter = True Then
                oExcelWrkSht.Rows(lStartRow & ":" & lStartRow).AutoFilter
            End If
            'Fit the columns to the content
            If bFitCols = True Then
                oExcelWrkSht.Range(oExcelWrkSht.Cells(lStartRow, lStartCol), _
                                   oExcelWrkSht.Cells(lStartRow, lStartCol + iCols)).EntireColumn.AutoFit
            End If
            'Start at the top
            oExcelWrkSht.Cells(lStartRow, lStartCol).Select
        Else
            MsgBox "There are no records returned by the specified queries/SQL statement.", _
                   vbCritical + vbOKOnly, "No data to generate an Excel spreadsheet with"
            GoTo Error_Handler_Exit
        End If
    End With
 
Error_Handler_Exit:
    On Error Resume Next
    oExcel.Visible = True   'Make excel visible to the user
    Set rs = Nothing
    Set oExcelWrkSht = Nothing
    Set oExcelWrkBk = Nothing
    oExcel.ScreenUpdating = True
    Set oExcel = Nothing
    Exit Function
 
Error_Handler:
    MsgBox "The following error has occured" & vbCrLf & vbCrLf & _
           "Error Number: " & Err.Number & vbCrLf & _
           "Error Source: ExportRecordset2XLS" & vbCrLf & _
           "Error Description: " & Err.Description & _
           Switch(Erl = 0, "", Erl <> 0, vbCrLf & "Line No: " & Erl) _
           , vbOKOnly + vbCritical, "An Error has Occured!"
    Resume Error_Handler_Exit
End Function

Select allOpen in new window