CODEWITHSUNDEEP
excelms-accessvba
R. Verstappen
R. Verstappen

Reputation: 13

Append to Excel from Access using VBA

With this particular problem I can’t get the code to append the exported data from Access to Excel. I have created an simple Access database with some data shown on a form. After that it is possible to export the shown record to Excel using the code.

So far so good. But when I export the next record it overwrites the previous exported data on row one in Excel. I want the code to append to the next row and so on.

I have found some topics on how to append with “ActiveCell.Value” and “ActiveCell.Offset” but my knowledge is too limited to get it to work with the code. The moment I think I got it, VBE comes with errors. It seems I can't figure this out.

Private Sub Command15_Click()
Dim oExcel          As Object
Dim oExcelWrkBk     As Object
Dim oExcelWrSht     As Object
Dim bExcelOpened    As Boolean

'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
'Set oExcelWrkBk = oExcel.Workbooks.Add()    'Start a new workbook
Set oExcelWrkBk = oExcel.Workbooks.Open("C:\test.xlsx")     'Open an existing Excel file
Set oExcelWrSht = oExcelWrkBk.Sheets(1) 'which worksheet to work with

'Start copying over your form values to the Excel Spreadsheet
'Cells(8, 3) = 8th row, 3rd column
oExcelWrSht.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0) = Me.1
oExcelWrSht.Cells(Rows.Count, 2).End(xlUp).Offset(1, 0) = Me.2
oExcelWrSht.Cells(Rows.Count, 3).End(xlUp).Offset(1, 0) = Me.3
oExcelWrSht.Cells(Rows.Count, 4).End(xlUp).Offset(1, 0) = Me.4
oExcelWrSht.Cells(Rows.Count, 5).End(xlUp).Offset(1, 0) = Me.5
oExcelWrSht.Cells(Rows.Count, 6).End(xlUp).Offset(1, 0) = Me.6
oExcelWrSht.Cells(Rows.Count, 7).End(xlUp).Offset(1, 0) = Me.7
oExcelWrSht.Cells(Rows.Count, 8).End(xlUp).Offset(1, 0) = Me.8
oExcelWrSht.Cells(Rows.Count, 9).End(xlUp).Offset(1, 0) = Me.9
'... and so on ...

oExcelWrSht.Range("A1").Select  'Return to the top of the page

'    oExcelWrkBk.Close True, sFileName 'Save and close the generated workbook
'    'Close excel if is wasn't originally running
'    If bExcelOpened = False Then
'        oExcel.Quit
'    End If Error_Handler_Exit:
On Error Resume Next
oExcel.Visible = True   'Make excel visible to the user
Set oExcelWrSht = Nothing
Set oExcelWrkBk = Nothing
oExcel.ScreenUpdating = True
Set oExcel = Nothing
Exit Sub Error_Handler:
MsgBox "The following error has occured" & vbCrLf & vbCrLf & _
       "Error Number: " & Err.Number & vbCrLf & _
       "Error Source: Export2XLS" & vbCrLf & _
       "Error Description: " & Err.Description _
       , vbOKOnly + vbCritical, "An Error has Occured!"
Resume Error_Handler_Exit End Sub

Upvotes: 1

Views: 4075

Answers (1)

Tim Edwards
Tim Edwards

Reputation: 1028

I've tried this and no problems so assuming you have a reference to the right excel library can you see if this works?

Sub Test()
Dim oExcel As Excel.Application
Dim oExcelWrkBk As Excel.Workbook
Dim oExcelWrSht As Excel.Worksheet

'Start Excel
On Error Resume Next
Set oExcel = GetObject(, "Excel.Application")
If Err <> 0 Then
    Err.Clear
    On Error GoTo Error_Handler
    Set oExcel = CreateObject("Excel.Application")
Else
    On Error GoTo Error_Handler
End If

oExcel.ScreenUpdating = False
oExcel.Visible = False 'This is false by default anyway

Set oExcelWrkBk = oExcel.Workbooks.Open("C:\test.xlsx")
Set oExcelWrSht = oExcelWrkBk.Sheets(1)

oExcelWrSht.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0) = "Test1"
oExcelWrSht.Cells(Rows.Count, 2).End(xlUp).Offset(1, 0) = "Test2"
oExcelWrSht.Cells(Rows.Count, 3).End(xlUp).Offset(1, 0) = "Test3"

oExcelWrSht.Range("A1").Select

oExcelWrkBk.Save

oExcel.ScreenUpdating = True
oExcel.Visible = True

Exit_Point:
Set oExcelWrSht = Nothing
Set oExcelWrkBk = Nothing
Set oExcel = Nothing
Exit Sub

Error_Handler:
MsgBox Err & " - " & Err.Description
GoTo Exit_Point
End Sub

Upvotes: 2

Related Questions