Sub ADOsendExtractData()
' exports data from the active worksheet to a table in an Access database
' this procedure must be edited before use
Dim conn As Object, rs As Object, r As Long
Dim dbFilePath As String
Dim strRAnumber As String
Dim strTS As String, strSql As String
Dim strMsg As String

dbFilePath = ThisWorkbook.Path & "\RAData.mdb"
    
    strRAnumber = GetDocProperty("Document Number")
    If Not Len(strRAnumber) > 0 Then
      strRAnumber = ActiveSheet.Name
    End If
    
    If Not strRAnumber Like "RA#######" Then
        MsgBox "RA: '" & strRAnumber & "' is not valid" & vbCrLf & vbCrLf & _
        "The active workbook must be a valid Excel Extract workbook with a RA Number specified", vbOKOnly + vbInformation, "RA Add Records"
        Exit Sub
    End If
    
    
    ' connect to the Access database
    Set conn = CreateObject("ADODB.CONNECTION")
    conn.Open "Provider=Microsoft.Jet.OLEDB.4.0; " & _
        "Data Source=" & dbFilePath & ";"
    
    r = 2 ' the start row in the worksheet
    Do While Len(Cells(r, 1).Formula) > 0
    ' repeat until first empty cell in column A
      strTS = Now()
      strSql = "INSERT INTO [Aircraftstatus] ( [RA Number], Model, SN, Analyst, TS ) " & _
              " VALUES (" & _
              "'" & strRAnumber & "'," & _
              "'" & Cells(r, 1) & "'," & _
              "'" & Cells(r, 2) & "'," & _
              "'" & Cells(r, 3) & "'," & _
              "'" & strTS & "')"
              
' INSERT INTO Aircraftstatus ( [RA Number], Model, SN )
  On Error Resume Next
 conn.Execute strSql

  If Err <> 0 Then
    Select Case Err.Number
        Case Is = -2147467259
          strMsg = "Record already exists"
        Case Else
          strMsg = "Error " & Err.Number & " " & Err.Description & "!"
    End Select
    
    Cells(r, 5) = "Failed: " & strMsg
  Else
    Cells(r, 5) = "Loaded"
    Cells(r, 6) = strTS
  End If
  
  On Error GoTo 0

        r = r + 1 ' next row
    Loop
    Set rs = Nothing
    conn.Close
    Set conn = Nothing
End Sub

''''''''''''' Functions ''''''''''''''

Public Function GetDocProperty(strPropName As String)
On Error GoTo GetDocProperty_Fail
GetDocProperty = ActiveWorkbook.CustomDocumentProperties(strPropName)

GetDocProperty_Fail:
  GetDocProperty = ""
End Function

 
dbFilePath = ThisWorkbook.Path & "\RAData.mdb"
strRAnum = Cells(r, 1)

strSQL = "UPDATE RAList SET " & strDBCols & ",RAList.TS ='" & Now() & "'" & _
        "  WHERE (((RAList.[RA Number])='" & strRAnum & "'))"
        
 ' Debug.Print strSql

  Set oADO = New ClassDataLayer
  Set oConnect = oADO.Connect(dbFilePath)
  
  oADO.Query strSQL

  oConnect.Close
  Set oConnect = Nothing
  Set oADO = Nothing

Public oConn As Object

Function Connect(dbFile As String) As Object

  'Open an ADO connection to the folder specified
  Set oConn = CreateObject("ADODB.CONNECTION")
  oConn.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _
  "Data Source=" & dbFile & ";"
  '& _
  '"Extended Properties=""text;HDR=Yes;FMT=Delimited"""
  
  Set Connect = oConn
End Function


Function Query(strQuery As String)
 Dim oRS As Object
 Set oRS = CreateObject("ADODB.RECORDSET")
 'Now actually open the text file and import into Excel
  oRS.Open strQuery, oConn, 3, 1, 1
  Set Query = oRS
End Function