Urgent ADO Help Needed

[In Distress]

Morning all,

I've got a small problem that I'm hoping people can help me out with.

I've been given the task of creating an excel tool capable of collecting certain information about attendees of an annual event, I thought this would be a great chance to tap into the power of ADO by using a VBA Userform front end that connects and updates data on an Access database. The problem being - seems I went a little over my head on promising to deliver this one is a very small time frame.

The scenario:

I have a 3 userforms named 'Opening, Questions, & Details'. The basic operation of this front end is to drag up all the details on the person that the user selects on the 'Opening' Userform, ask the person a few questions which are selected by using radio buttons on the 'Questions' form and also update any person details on the 'Details' userform. Then I want to send all this information back to access database to update the record.

I have managed to figure out how to drag up all the information on a person from the database. Basically, when the user selects a name from a combobox on the 'Opening' userform, I have a small script that locates that person on the database, then copies all the columns of data for that person into a seperate sheet called 'Sheet3'. There are approx. 23 columns of data for each person in the database.

The code I use to grab all the persons details is as follows:

Public Sub GetInviteesDetailsFromDB()
Const ConnectionString As String = "Provider=Microsoft.Jet.OLEDB.4.0;" + _
      "Data Source = C:\Documents and Settings\HPUser\Desktop\AGM_2006.mdb;Persist Security Info=False"
Dim SQL

SQL = "SELECT DB_Name,DB_Partner,DB_Position,DB_Company,DB_Address1,DB_Address2,DB_Suburb,DB_State,DB_PostCode,DB_Phone1,DB_Phone2,DB_Phone3,DB_Email,DB_Fax,DB_PrefFormat,DB_Type,DB_ID FROM AGMtable WHERE DB_Name = '" & SelectedName & "'"
Dim Recordset As ADODB.Recordset

Sheets("Sheet3").Select
Sheets("Sheet3").Range("A1:E600").Select
    With Selection
        .ClearContents
    End With
Sheet3.Range("A1").Select

Set Recordset = New ADODB.Recordset

Call Recordset.Open(SQL, ConnectionString, CursorTypeEnum.adOpenForwardOnly, _
     LockTypeEnum.adLockReadOnly, CommandTypeEnum.adCmdText)

If Not Recordset.EOF Then
    Call Sheet3.Range("e2").CopyFromRecordset(Recordset)
    With Sheet3.Range("A1:C1")
        .Value = Array("Name", "Company", "Phone No")
        .Font.Bold = True
    End With
    Sheet3.UsedRange.EntireColumn.AutoFit
    Else
        Call MsgBox("Error: No Records returned.", vbCritical)
End If

End Sub

The problem I can't seem to fix is how to update the record on the database. I have tried stripping down the Plain text SQL script, but I'm still getting an error of a 'Type mismatch in criteria expression".

To give you details, the database name is AGM_2006.mdb. The table in the database is called 'AGMtable'. The fields contained in the table are as follows: 'DB_ID' (This is the primary Key). 'DB_Name', 'DB_Parnter', 'DB_Position', 'DB_Company', 'DB_Address1', 'DB_Address2', 'DB_Suburb', 'DB_State', 'DB_Postcode', 'DB_Phone1', 'DB_Phone2', 'DB_Phone3', 'DB_Email', 'DB_Fax', 'DB_PrefFormat', 'DB_Type', 'DB_Q1', 'DB_Q2A', 'DB_Q2B', 'DB_Q3', 'DB_Q4A', 'DB_Q4B'.

To help clarify - Say a user selects Person "C A Problem" from the Combobox on the 'Opening form'. A code snippet establishes a connection to the database, finds "C A Problem" and returns all the columns of data mentioned above into a sheet called "Sheet3" and closes the connection. This data is then used to populate values on the 'Details' Userform. Once the user has made changes and selected answers on the 'Details' and 'Questions' userforms respectively, then new values are written to "Sheet3" into their respective columns, replacing the values that were retrieved from the database. When the user clicks on the finish button, I want to write all the information on sheet3 back to the record of "C A Problem" on the database.

I apologise for the long winded post, but I had to give you all the details to hopefully prevent a back and forth of needed details. If someone can also tell me how to create a 'New Record' to the database as well, that would be great, because that's the last piece of the puzzle. I need to get this done today (I know, always over estimate timeframes, but I didn't), so anyone that can help me out A.S.A.P, just may save my skin.

Thanks in advance all.

 

[Legacy 98055]

First, change your cursor lock type from "adLockReadOnly" to "adLockOptimistic". You cannot update a recordset with read-only access. I don't think that your cursor type, "adOpenForwardOnly", supports adding new records. Change it to "adOpenKeyset".

This is a very stripped down example. However, it does show you how to do everything you asked for. Normally, when I import a recordset into a range for editing, I mark the rows that have changed so that I do not need to update every reocord in the recordset. I do not know exactly how you are updating your ranges so I did not bother incuding this functionality... See the download that contains a sample database as well. Extract both files to the same path...

In Distress.zip

<table width="100%" border="1" bgcolor="White" style="filterrogid:DXImageTransform.Microsoft.Gradient(endColorstr='#C0CFE2', startColorstr='#FFFFFF', gradientType='0');"><tr><TD><font size="2" face=Courier New>  <font color="#0000A0">Option</font> <font color="#0000A0">Explicit</font>

  <font color="#0000A0">Dim</font> rs <font color="#0000A0">As</font> ADODB.Recordset
  <font color="#0000A0">Dim</font> cn <font color="#0000A0">As</font> ADODB.Connection

  <font color="#0000A0">Sub</font> ExampleGetData()
       <font color="#0000A0">If</font> cn <font color="#0000A0">Is</font> <font color="#0000A0">Nothing</font> <font color="#0000A0">Then</font> OpenConnection
       <font color="#0000A0">Call</font> UpdateWorksheetFromRecordset
  <font color="#0000A0">End</font> <font color="#0000A0">Sub</font>

  <font color="#0000A0">Sub</font> ExampleAddRecord()
       <font color="#0000A0">If</font> cn <font color="#0000A0">Is</font> <font color="#0000A0">Nothing</font> <font color="#0000A0">Then</font> OpenConnection
       <font color="#0000A0">If</font> rs <font color="#0000A0">Is</font> <font color="#0000A0">Nothing</font> <font color="#0000A0">Then</font> UpdateWorksheetFromRecordset
      <font color="#008000"> 'assuming that ID is autonumber.</font>
       <font color="#0000A0">If</font> rs.Supports(adAddNew) <font color="#0000A0">Then</font>
           <font color="#0000A0">Call</font> AddNewRecord(Array("Some name", "Some Company", "Some Phone #", "Some Zipcode", "Some State"))
       <font color="#0000A0">End</font> <font color="#0000A0">If</font>
  <font color="#0000A0">End</font> <font color="#0000A0">Sub</font>

  <font color="#0000A0">Sub</font> AddNewRecord(Values)
       rs.AddNew
       rs!DB_NAME = Values(0)
       rs!DB_COMPANY = Values(1)
       rs!DB_PHONE = Values(2)
       rs!DB_ZIPCODE = Values(3)
       rs!DB_STATE = Values(4)
       rs.Update
       <font color="#0000A0">Call</font> UpdateWorksheetFromRecordset
  <font color="#0000A0">End</font> <font color="#0000A0">Sub</font>

  <font color="#008000">'edit some of the data in your cells and then run this sub</font>
  <font color="#008000">'to update the recordset which will then update the database</font>
  <font color="#0000A0">Sub</font> UpdateRecordsetFromWorksheet()
       <font color="#0000A0">Dim</font> r <font color="#0000A0">As</font> Range

       rs.MoveFirst

       <font color="#0000A0">With</font> Sheets("Sheet3")
           <font color="#0000A0">For</font> <font color="#0000A0">Each</font> r <font color="#0000A0">In</font> .Range(.Cells(2, 1), .Cells(.UsedRange.Rows.Count, 1))
               <font color="#0000A0">Set</font> r = r.Resize(, 6)
               rs!DB_NAME = r(2)
               rs!DB_COMPANY = r(3)
               rs!DB_PHONE = r(4)
               rs!DB_ZIPCODE = r(5)
               rs!DB_STATE = r(6)
               rs.MoveNext
           <font color="#0000A0">Next</font>
       <font color="#0000A0">End</font> <font color="#0000A0">With</font>

       rs.MoveFirst
       rs.Update

  <font color="#0000A0">End</font> <font color="#0000A0">Sub</font>

  <font color="#0000A0">Public</font> <font color="#0000A0">Sub</font> UpdateWorksheetFromRecordset()
      <font color="#008000"> 'Const ConnectionString As String = "Provider=Microsoft.Jet.OLEDB.4.0;" + _</font>
      <font color="#008000"> ' "Data Source = C:\Documents and Settings\HPUser\Desktop\AGM_2006.mdb;Persist Security Info=False"</font>

       <font color="#0000A0">Dim</font> SQL <font color="#0000A0">As</font> String, sh <font color="#0000A0">As</font> Worksheet

       <font color="#0000A0">Set</font> sh = Sheets("Sheet3")

       SQL = "SELECT * FROM AGMtable"

       Application.Goto sh.Range("A1")
       sh.Range("A1:F600").Clear

       <font color="#0000A0">If</font> rs <font color="#0000A0">Is</font> <font color="#0000A0">Nothing</font> <font color="#0000A0">Then</font> <font color="#0000A0">Set</font> rs = <font color="#0000A0">New</font> ADODB.Recordset

       <font color="#0000A0">If</font> rs.State = adStateClosed <font color="#0000A0">Then</font>
           <font color="#0000A0">Call</font> rs.Open(SQL, cn, adOpenKeyset, adLockOptimistic, adCmdText)
       <font color="#0000A0">Else</font>
           rs.Requery
       <font color="#0000A0">End</font> <font color="#0000A0">If</font>

       <font color="#0000A0">If</font> <font color="#0000A0">Not</font> rs.EOF <font color="#0000A0">Then</font>

           <font color="#0000A0">Call</font> sh.Range("A2").CopyFromRecordset(rs)

           <font color="#0000A0">With</font> sh.Range("A1:F1")
               .Value = Array(rs.Fields(0).Name, rs.Fields(1).Name, _
                              rs.Fields(2).Name, rs.Fields(3).Name, _
                              rs.Fields(4).Name, rs.Fields(5).Name)
               .Font.Bold = <font color="#0000A0">True</font>
               .Columns.EntireColumn.AutoFit
           <font color="#0000A0">End</font> <font color="#0000A0">With</font>

       <font color="#0000A0">Else</font>
           <font color="#0000A0">Call</font> MsgBox("Error: No Records returned.", vbCritical)
       <font color="#0000A0">End</font> <font color="#0000A0">If</font>

  <font color="#0000A0">End</font> <font color="#0000A0">Sub</font>

  <font color="#0000A0">Sub</font> OpenConnection()
       <font color="#0000A0">Set</font> cn = <font color="#0000A0">New</font> Connection
       cn.Open "Provider=Microsoft.Jet.OLEDB.4.0;" + _
             "Data Source = " & ThisWorkbook.Path & "\db1.mdb;Persist Security Info=False"
  <font color="#0000A0">End</font> <font color="#0000A0">Sub</font>
</FONT></td></tr></table><button onclick='document.all("103200602231375").value=document.all("103200602231375").value.replace(/<br \/>\s\s/g,"");document.all("103200602231375").value=document.all("103200602231375").value.replace(/<br \/>/g,"");window.clipboardData.setData("Text",document.all("103200602231375").value);'>Copy to Clipboard</BUTTON><textarea style="position:absolute;visibility:hidden" name="103200602231375" wrap="virtual">
Option Explicit

Dim rs As ADODB.Recordset
Dim cn As ADODB.Connection

Sub ExampleGetData()
If cn Is Nothing Then OpenConnection
Call UpdateWorksheetFromRecordset
End Sub

Sub ExampleAddRecord()
If cn Is Nothing Then OpenConnection
If rs Is Nothing Then UpdateWorksheetFromRecordset
'assuming that ID is autonumber.
If rs.Supports(adAddNew) Then
Call AddNewRecord(Array("Some name", "Some Company", "Some Phone #", "Some Zipcode", "Some State"))
End If
End Sub

Sub AddNewRecord(Values)
rs.AddNew
rs!DB_NAME = Values(0)
rs!DB_COMPANY = Values(1)
rs!DB_PHONE = Values(2)
rs!DB_ZIPCODE = Values(3)
rs!DB_STATE = Values(4)
rs.Update
Call UpdateWorksheetFromRecordset
End Sub

'edit some of the data in your cells and then run this sub
'to update the recordset which will then update the database
Sub UpdateRecordsetFromWorksheet()
Dim r As Range

rs.MoveFirst

With Sheets("Sheet3")
For Each r In .Range(.Cells(2, 1), .Cells(.UsedRange.Rows.Count, 1))
Set r = r.Resize(, 6)
rs!DB_NAME = r(2)
rs!DB_COMPANY = r(3)
rs!DB_PHONE = r(4)
rs!DB_ZIPCODE = r(5)
rs!DB_STATE = r(6)
rs.MoveNext
Next
End With

rs.MoveFirst
rs.Update

End Sub

Public Sub UpdateWorksheetFromRecordset()
'Const ConnectionString As String = "Provider=Microsoft.Jet.OLEDB.4.0;" + _
' "Data Source = C:\Documents and Settings\HPUser\Desktop\AGM_2006.mdb;Persist Security Info=False"

Dim SQL As String, sh As Worksheet

Set sh = Sheets("Sheet3")

SQL = "SELECT * FROM AGMtable"

Application.Goto sh.Range("A1")
sh.Range("A1:F600").Clear

If rs Is Nothing Then Set rs = New ADODB.Recordset

If rs.State = adStateClosed Then
Call rs.Open(SQL, cn, adOpenKeyset, adLockOptimistic, adCmdText)
Else
rs.Requery
End If

If Not rs.EOF Then

Call sh.Range("A2").CopyFromRecordset(rs)

With sh.Range("A1:F1")
.Value = Array(rs.Fields(0).Name, rs.Fields(1).Name, _
rs.Fields(2).Name, rs.Fields(3).Name, _
rs.Fields(4).Name, rs.Fields(5).Name)
.Font.Bold = True
.Columns.EntireColumn.AutoFit
End With

Else
Call MsgBox("Error: No Records returned.", vbCritical)
End If

End Sub

Sub OpenConnection()
Set cn = New Connection
cn.Open "Provider=Microsoft.Jet.OLEDB.4.0;" + _
"Data Source = " & ThisWorkbook.Path & "\db1.mdb;Persist Security Info=False"
End Sub</textarea>

In Distress.zip

 

[In Distress]

Tom, You're a legend. Worked a treat. thanks for taking the time out to firstly read the post, then post a reply.

Thanks again.