VBA Loop to next row and highligth the Error in the sheet

[mielkew]

Hi All,

I have been using the below code which I have got from one of website, however, the user always tend to forget to check whether the data (IDs) are already send to Access Database, is there any way to loop the process and still export the data and change the font color of item not processed?

Sub Export_Data()
Dim cnn As ADODB.Connection 'dim the ADO collection class
Dim rst As ADODB.Recordset 'dim the ADO recordset class
Dim dbPath
Dim x As Long, i As Long
Dim nextrow As Long

'add error handling
On Error GoTo errHandler:


'Variables for file path and last row of data
dbPath = ActiveSheet.Range("I3").Value
nextrow = Cells(Rows.Count, 1).End(xlUp).Row

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

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

'Connection class is equipped with a —method— named Open
'—-4 aguments—- ConnectionString, UserID, Password, Options
'ConnectionString formula—-Key1=Value1;Key2=Value2;Key_n=Value_n;
cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & dbPath
'two primary providers used in ADO SQLOLEDB —-Microsoft.JET.OLEDB.4.0 —-Microsoft.ACE.OLEDB.12.0
'OLE stands for Object Linking and Embedding, Database

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

'ConnectionString Open '—-5 aguments—-
'Source, ActiveConnection, CursorType, LockType, Options
rst.Open Source:="PhoneList", ActiveConnection:=cnn, _
CursorType:=adOpenDynamic, LockType:=adLockOptimistic, _
Options:=adCmdTable

'you now have the recordset object
'add the values to it
For x = 2 To nextrow
rst.AddNew
For i = 1 To 7
rst(Cells(1, i).Value) = Cells(x, i).Value
Next i
rst.Update
Next x

'close the recordset
rst.Close
' Close the connection
cnn.Close
'clear memory
Set rst = Nothing
Set cnn = Nothing

'communicate with the user
MsgBox " The data has been successfully sent to the access database"

'Update the sheet
Application.ScreenUpdating = True

'show the next ID
Sheet1.Range("J3").Value = Sheet1.Range("K3").Value + 1

'Clear the data
Sheet1.Range("A2:G1000").ClearContents
On Error GoTo 0
Exit Sub
errHandler:

'clear memory
Set rst = Nothing
Set cnn = Nothing
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure Export_Data"
End Sub

Appreciate any help, as I don't know how to begin with the loop resume next