0

UPDATED QUESTION: I have Update sheet, this sheet contains unique ID that matched the access database ID, I'm trying to update the fields using excel values in "Update" sheet. The ID is in the Column A the rest of the fields are stored from Column B to R. I'm trying to achieve the below, As follows:

  1. Update the record(values from Column B to R) if Column A (ID) matched existing Access database ID. Then add text in Column S "Updated"
  2. If the Column A (ID) did not found any match in the existing Access database ID, Then add text in Column S "ID NOT FOUND"
  3. Loop to next value

So far, I have the below Sub for Update and Function for Existing ID (Import_Update Module), but I'm getting this error.

enter image description here

Sub Update_DB()

Dim dbPath As String
Dim lastRow As Long
Dim exportedRowCnt As Long
Dim NotexportedRowCnt As Long
Dim qry As String
Dim ID As String

'add error handling
On Error GoTo exitSub

'Check for data
    If Worksheets("Update").Range("A2").Value = "" Then
    MsgBox "Add the data that you want to send to MS Access"
        Exit Sub
    End If

    'Variables for file path
    dbPath = Worksheets("Home").Range("P4").Value '"W:\Edward\_Connection\Database.accdb"  '##> This was wrong before pointing to I3

    If Not FileExists(dbPath) Then
        MsgBox "The Database file doesn't exist! Kindly correct first"
            Exit Sub
    End If

    'find las last row of data
    lastRow = Cells(Rows.Count, 1).End(xlUp).Row

    Dim cnx As ADODB.Connection 'dim the ADO collection class
    Dim rst As ADODB.Recordset 'dim the ADO recordset class

    On Error GoTo errHandler

    'Initialise the collection class variable
    Set cnx = New ADODB.Connection

    'Connection class is equipped with a —method— named Open
     cnx.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & dbPath


    'ADO library is equipped with a class named Recordset
    Set rst = New ADODB.Recordset 'assign memory to the recordset

'##> ID and SQL Query

    ID = Range("A" & lastRow).Value
    qry = "SELECT * FROM f_SD WHERE ID = '" & ID & "'"

    'ConnectionString Open '—-5 aguments—-
    rst.Open qry, ActiveConnection:=cnx, _
    CursorType:=adOpenDynamic, LockType:=adLockOptimistic, _
    Options:=adCmdTable

    'add the values to it

    'Wait Cursor
    Application.Cursor = xlWait

    'Pause Screen Update
    Application.ScreenUpdating = False

    '##> Set exportedRowCnt to 0 first
    UpdatedRowCnt = 0
    IDnotFoundRowCnt = 0

    If rst.EOF And rst.BOF Then
        'Close the recordet and the connection.
        rst.Close
        cnx.Close
        'clear memory
        Set rst = Nothing
        Set cnx = Nothing
        'Enable the screen.
        Application.ScreenUpdating = True
        'In case of an empty recordset display an error.
        MsgBox "There are no records in the recordset!", vbCritical, "No Records"
    Exit Sub

    End If

    For nRow = 2 To lastRow
        '##> Check if the Row has already been imported?
        '##> Let's suppose Data is on Column B to R.
        'If it is then continue update records
        If IdExists(cnx, Range("A" & nRow).Value) Then

        With rst

        For nCol = 1 To 18
            rst.Fields(Cells(1, nCol).Value2) = Cells(nRow, nCol).Value 'Using the Excel Sheet Column Heading
        Next nCol

        Range("S" & nRow).Value2 = "Updated"
        UpdatedRowCnt = UpdatedRowCnt + 1

     rst.Update

     End With

        Else

            '##>Update the Status on Column S when ID NOT FOUND
            Range("S" & nRow).Value2 = "ID NOT FOUND"

            'Increment exportedRowCnt
            IDnotFoundRowCnt = IDnotFoundRowCnt + 1
        End If
    Next nRow

    'close the recordset
    rst.Close

    ' Close the connection
    cnx.Close
    'clear memory
    Set rst = Nothing
    Set cnx = Nothing

    If UpdatedRowCnt > 0 Or IDnotFoundRowCnt > 0 Then
        'communicate with the user
        MsgBox UpdatedRowCnt & " Drawing(s) Updated " & vbCrLf & _
          IDnotFoundRowCnt & " Drawing(s) IDs Not Found"

    End If


    'Update the sheet
    Application.ScreenUpdating = True
exitSub:
    'Restore Default Cursor
    Application.Cursor = xlDefault

    'Update the sheet
    Application.ScreenUpdating = True
        Exit Sub

errHandler:
    'clear memory
    Set rst = Nothing
    Set cnx = Nothing
        MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure Update_DB"

    Resume exitSub
End Sub

Function to Check if the ID Exists

Function IdExists(cnx As ADODB.Connection, sId As String) As Boolean

'Set IdExists as False and change to true if the ID exists already
IdExists = False

'Change the Error handler now
Dim rst As ADODB.Recordset 'dim the ADO recordset class
Dim cmd As ADODB.Command   'dim the ADO command class

On Error GoTo errHandler

'Sql For search
Dim sSql As String
sSql = "SELECT Count(PhoneList.ID) AS IDCnt FROM PhoneList WHERE (PhoneList.ID='" & sId & "')"

'Execute command and collect it into a Recordset
Set cmd = New ADODB.Command
cmd.ActiveConnection = cnx
cmd.CommandText = sSql

'ADO library is equipped with a class named Recordset
Set rst = cmd.Execute 'New ADODB.Recordset 'assign memory to the recordset

'Read First RST
rst.MoveFirst

'If rst returns a value then ID already exists
If rst.Fields(0) > 0 Then
    IdExists = True
End If

'close the recordset
rst.Close

'clear memory
Set rst = Nothing
exitFunction:
    Exit Function

errHandler:
'clear memory
Set rst = Nothing
    MsgBox "Error " & Err.Number & " :" & Err.Description
End Function
9
  • 2
    And the question/problem is? Commented Apr 12, 2020 at 11:04
  • 1
    Please edit the question, don't post the actual question in the comments Commented Apr 12, 2020 at 13:04
  • @Mielew, could you please explain what is your issue and your challenge in the Question again? We do not understand the question please Commented Apr 12, 2020 at 16:23
  • Hi @Tsiriniaina Rakotonirina, I would like to update the existing records in AccessDB, I have export sheet that loop into the entire rows and add the information in accessDB. I have the update sheet with new data that I want to append to the existing record, as long as the ID provided is correctly, then data should be updated for the same ID in the AccessDB and have confirmation text in the last column "Updated" or if ID do not found match in the existing record "ID NOT FOUND" Link:(hbkcrccjv-my.sharepoint.com/:f:/p/edward/…) Commented Apr 13, 2020 at 5:27
  • @Mielkew, I'm opening the files but I don't understand your intention. Could you explain what is the Update Sheet for please? Commented Apr 13, 2020 at 11:10

2 Answers 2

2

My below code is working fine. I tried to address your above three points in a different way.

########################## IMPORTANT

1) I have removed your other validations; you can add them back. 2) DB path has been hard coded, you can set it to get from a cells again 3) My DB has only two fields (1) ID and (2) UserName; you will have obtain your other variables and update the UPDATE query.

Below is the code which is working fine to meet your all 3 requests...Let me know how it goes...

Tschüss :)

Sub UpdateDb()

'Creating Variable for db connection
Dim sSQL As String
Dim rs As ADODB.Recordset
Dim cn As ADODB.Connection
Set cn = New ADODB.Connection

cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=C:\test\db.accdb;"

Dim a, PID

'a is the row counter, as it seems your data rows start from 2 I have set it to 2
a = 2

'Define variable for the values from Column B to R. You can always add the direct ceel reference to the SQL also but it will be messy.
'I have used only one filed as UserName and so one variable in column B, you need to keep adding to below and them to the SQL query for othe variables
Dim NewUserName


'########Strating to read through all the records untill you reach a empty column.
While VBA.Trim(Sheet19.Cells(a, 1)) <> "" ' It's always good to refer to a sheet by it's sheet number, bcos you have the fleibility of changing the display name later.
'Above I have used VBA.Trim to ignore if there are any cells with spaces involved. Also used VBA pre so that code will be supported in many versions of Excel.

        'Assigning the ID to a variable to be used in future queries
        PID = VBA.Trim(Sheet19.Cells(a, 1))

       'SQL to obtain data relevatn to given ID on the column. I have cnsidered this ID as a text
        sSQL = "SELECT ID FROM PhoneList WHERE ID='" & PID & "';"

        Set rs = New ADODB.Recordset
        rs.Open sSQL, cn

          If rs.EOF Then

                'If the record set is empty
                'Updating the sheet with the status
                Sheet19.Cells(a, 19) = "ID NOT FOUND"
                'Here if you want to add the missing ID that also can be done by adding the query and executing it.

            Else

                  'If the record found
                  NewUserName = VBA.Trim(Sheet19.Cells(a, 2))
                  sSQL = "UPDATE PhoneList SET UserName ='" & NewUserName & "' WHERE ID='" & PID & "';"
                  cn.Execute (sSQL)

                  'Updating the sheet with the status
                  Sheet19.Cells(a, 19) = "Updated"

          End If

       'Add one to move to the next row of the excel sheet
       a = a + 1

 Wend

cn.Close
Set cn = Nothing

End Sub
Sign up to request clarification or add additional context in comments.

2 Comments

Hi @M. Antoney It works, I tried to declare all the information needed, however, the date value however not getting through.
I don't know if I'm doing it right. sSQL = "UPDATE PhoneList SET Submit_Date ='" & Submit_Date & "' ActionCode ='" & ActionCode & "'WHERE ID='" & PID & "';". How can i declare more than just one Column I changed the NewUserName to ActionCode and added Submit_Date. then I define these 3 variable I only added two in the sSQL but somehow not able to work Dim ActionCode Dim Submit_Date Dim Receive_Date then I have these ActionCode = VBA.Trim(Sheet2.Cells(a, 2)) and Submit_Date = VBA.Trim(Sheet2.Cells(a, 3)) and Receive_Date = VBA.Trim(Sheet2.Cells(a, 4))
1

You need to put the query inside the loop

Option Explicit

Sub Update_DB_1()

    Dim cnx As New ADODB.Connection
    Dim rst As New ADODB.Recordset
    Dim qry As String, id As String, sFilePath As String
    Dim lastRow As Long, nRow As Long, nCol As Long, count  As Long

    Dim wb As Workbook, ws As Worksheet
    Set wb = ThisWorkbook
    Set ws = wb.Sheets("Update")

    lastRow = ws.Cells(Rows.count, 1).End(xlUp).Row
    sFilePath = wb.Worksheets("Home").Range("P4").Value

    cnx.open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & sFilePath

    count = 0
    For nRow = 2 To lastRow

        id = Trim(ws.Cells(nRow, 1))
        qry = "SELECT * FROM f_SD WHERE ID = '" & id & "'"
        Debug.Print qry

        rst.open qry, cnx, adOpenKeyset, adLockOptimistic
        If rst.RecordCount > 0 Then
            ' Update RecordSet using the Column Heading
            For nCol = 2 To 9
                rst.fields(Cells(1, nCol).Value2) = Cells(nRow, nCol).Value
            Next nCol
            rst.Update
            count = count + 1
            ws.Range("S" & nRow).Value2 = "Updated"
        Else
            ws.Range("S" & nRow).Value2 = "ID NOT FOUND"
        End If

        rst.Close

    Next nRow

    cnx.Close
    Set rst = Nothing
    Set cnx = Nothing

    MsgBox count & " records updated", vbInformation

End Sub

1 Comment

Works like a champ Thanks @CDP1802!

Start asking to get answers

Find the answer to your question by asking.

Ask question

Explore related questions

See similar questions with these tags.