Appending data from Access to Excel

I need to append data to an existing Excel files worksheet

1:lLastRow = ActiveSheet.Cells(ActiveSheet.Rows.Count, 1).End(xlUp).Row

I have the following code provided by Daniel Pineault

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 = 7, _
                             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 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"
 
    '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!
            '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
            'Copy the data from our query into Excel
            '***************************************
            oExcelWrkSht.Cells(lStartRow + 1, lStartCol).CopyFromRecordset rs
            
            '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

Open in new window


I need to add the following line I just don't know where to add it.

lLastRow = ActiveSheet.Cells(ActiveSheet.Rows.Count, 1).End(xlUp).Row

Open in new window


Any thoughts?

John
John SheehySystem Security ManagerAsked:
Who is Participating?
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

Daniel PineaultPresident / Owner CARDA Consultants Inc.Commented:
Sorry John for not getting back to you sooner.

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

Open in new window

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

Open in new window

John SheehySystem Security ManagerAuthor Commented:
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, _ 

Open in new window


What are your thoughts?

John
John SheehySystem Security ManagerAuthor Commented:
Defining it didn't help either.
John SheehySystem Security ManagerAuthor Commented:
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
John SheehySystem Security ManagerAuthor Commented:
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

Open in new window

It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
Microsoft Access

From novice to tech pro — start learning today.