VBA code to Import and Add Record to Access

[darkdarkwt]

Hi

The ideal is to create a button in excel , when user clicked the button it will import and add record to Ms Access

Sub AddRecordtoAccess()
    Dim oAcc As Object
    Dim rstTable As Object
    Dim LRow As Long
    Set oAcc = CreateObject("Access.Application")
    LRow = Sheet1.Range("B" & Rows.Count).End(xlUp).Row
    'Open Database in Microsoft Access window
    oAcc.OpenCurrentDatabase "C:\Users\WFOO\Desktop\Yong Leong\Project Deadline Search Engine.accdb", True
    
    oAcc.Visible = False
    
    'Create a Recordset based on <Table name>
    Set rstTable = oAcc.CurrentDb.OpenRecordset("MainRecords")
    
    With rstTable
        .AddNew
        !Field("Project Name") = Range("A2:A" & LRow).Value
        !Field("Element") = Sheet1.Cells.Range("B2:B" & LRow).Value
       ![Deliverable/Review] = Sheet1.Cells.Range("C2:C" & LRow).Value
      ![Responsibility] = Sheet1.Cells.Range("D2:D" & LRow).Value
       ![Target Date] = Sheet1.Cells.Range("E2:E" & LRow).Value
      ![Status] = Sheet1.Cells.Range("F2:F" & LRow).Value
      ![Stage 1] = Sheet1.Cells.Range("G2:G" & LRow).Value
      ![Stage 2] = Sheet1.Cells.Range("H2:H" & LRow).Value
       ![Stage 3] = Sheet1.Cells.Range("I2:I" & LRow).Value
      ![Stage 4] = Sheet1.Cells.Range("J2:J" & LRow).Value
       ![Stage 5] = Sheet1.Cells.Range("K2:K" & LRow).Value
      ![Comments] = Sheet1.Cells.Range("L2:L" & LRow).Value
        .Update
    End With
    
    oAcc.Quit
    Set oAcc = Nothing
    
End Sub

i have this code but i dont know where goes wrong .....

thank you for your help ><

 

[apr pillai]

This method requires that you add each row of values to the table. Modified code is given below:

Sub AddRecordtoAccess()
    Dim oAcc As Object
    Dim rstTable As Object
    Dim LRow As Long, SRow as Long
    Set oAcc = CreateObject("Access.Application")
    LRow = Sheet1.Range("B" & Rows.Count).End(xlUp).Row
    'Open Database in Microsoft Access window
    oAcc.OpenCurrentDatabase "C:\Users\WFOO\Desktop\Yong Leong\Project Deadline Search Engine.accdb", True
    
    oAcc.Visible = False
    
    'Create a Recordset based on 
    Set rstTable = oAcc.CurrentDb.OpenRecordset("MainRecords")
    
    With rstTable
      For SRow = 2 to LRow
        .AddNew
        .Fields("Project Name").Value = Range("A" & SRow & ":A" & SRow).Value
        .Fields("Element").value = Sheet1.Cells.[FONT=Verdana]Range("B" & SRow & ":B" & SRow).Value[/FONT]
      ![Deliverable/Review] = Sheet1.Cells.[FONT=Verdana]Range("C" & SRow & ":C" & SRow).Value[/FONT]
      ![Responsibility] = Sheet1.Cells.[FONT=Verdana]Range("D" & SRow & ":D" & SRow).Value[/FONT]
      ![Target Date] = Sheet1.Cells.[FONT=Verdana]Range("E" & SRow & ":E" & SRow).Value[/FONT]
      ![Status] = Sheet1.Cells.[FONT=Verdana]Range("F" & SRow & ":F" & SRow).Value[/FONT]
      ![Stage 1] = Sheet1.Cells.[FONT=Verdana]Range("G" & SRow & ":G" & SRow).Value[/FONT]
      ![Stage 2] = Sheet1.Cells.[FONT=Verdana]Range("H" & SRow & ":H" & SRow).Value[/FONT]
      ![Stage 3] = Sheet1.Cells.[FONT=Verdana]Range("I" & SRow & ":I" & SRow).Value[/FONT]
      ![Stage 4] = Sheet1.Cells.[FONT=Verdana]Range("J" & SRow & ":J" & SRow).Value[/FONT]
      ![Stage 5] = Sheet1.Cells.[FONT=Verdana]Range("K" & SRow & ":K" & SRow).Value[/FONT]
      ![Comments] = Sheet1.Cells.[FONT=Verdana]Range("L" & SRow & ":L" & SRow).Value[/FONT]
        .Update
      Next
    End With
    rstTable.close
    oAcc.Quit
    Set oAcc = Nothing
    
End Sub