JezLisle


Hi, I am new to this ADO querying....

Basically what I am trying to do is take a range of data from a defined Range on an excel sheet and import that into a table already set up in a Access Database.

From reading some details on this I understand that an ADO Connection is the way to go. My problem now is understanding what I need to write as my VBA code to do this.

Can anyone help

Thanks, Jez




Re: Connecting to Access Database via ADO from Excel

ADG


Hi Jez

I find DAO easier than ADO. The below example is from a live spreadsheet . The example looks to see if the cell(s) updated refer to data which should be in the database, if so the database is opened and the data is transfered to a table called shutdowns:

Private Sub Worksheet_Change(ByVal Target As Range)
Dim db As DAO.Database
Dim rs As DAO.Recordset

Dim lngRow, lngCol As Long

If Me.Cells(2, 3).Value = "Yes" Then

For Each c In Target
lngRow = c.Row
lngCol = c.Column
If ((lngRow >= 6) And (lngCol >= 5)) Then
If ((Me.Cells(lngRow, 2).Value > 51000) And (Me.Cells(4, lngCol).Value > 38000)) Then
Set db = DBEngine(0).OpenDatabase("n:\Access databases\Peoplesoft Daily Production.mdb")
Set rs = db.OpenRecordset("Shutdowns")
rs.Index = "PrimaryKey"
rs.Seek "=", Me.Cells(lngRow, 2).Value, Me.Cells(4, lngCol).Value
If rs.NoMatch Then
rs.AddNew
rs![WORK CENTRE] = Me.Cells(lngRow, 2).Value
rs!Date = Me.Cells(4, lngCol).Value
If Me.Cells(5, lngCol).Value = "Day" Then
rs!Day = Me.Cells(lngRow, lngCol).Value
rs!Night = 0
Else
If Me.Cells(5, lngCol).Value = "Night" Then
rs!Night = Me.Cells(lngRow, lngCol).Value
rs!Day = 0
End If
End If
rs!SHUTDOWN = rs!Day + rs!Night
rs.Update

Else
rs.Edit
If Me.Cells(5, lngCol).Value = "Day" Then
rs!Day = Me.Cells(lngRow, lngCol).Value
Else
If Me.Cells(5, lngCol).Value = "Night" Then
rs!Night = Me.Cells(lngRow, lngCol).Value
End If
End If
rs!SHUTDOWN = rs!Day + rs!Night
rs.Update
End If
rs.Close
Set rs = Nothing
db.Close
Set db = Nothing
End If

End If
Next c
End If
End Sub

The above is more complicated than you need but the green lines should give you an idea.






Re: Connecting to Access Database via ADO from Excel

JezLisle

Thanks for the reply,

I found a way of doing what I was wanting to do, but now have an error on this line below.

The Error: Item cannot be found in the collection corresponding to the requested name or ordinal

Line: cmd("iKPIScore").Value = .Cells(i + 1, 9).Value

Basically all I am trying to do is import a table of data from Excel to a table in Access and store the data in the approriate formats.

Attached is the code in which pull all info into the database, well should do.

How can I fix this error

If needs be I could zip up the file and send.

Jez
Const cConnection = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=D:\Work\BonusMatrix\BonusReviews.mdb;"
' takes a range and a paramterized insert query
Function submitPDRInfo(shtRng As Range, pInsQry As String) As Long
Dim i As Long, lngLastRow As Long, blnCommit As Boolean
Dim con As ADODB.Connection, cmd As ADODB.Command

On Error GoTo e1
Debug.Print pInsQry
Set con = New ADODB.Connection
con.Open cConnection 'Open connection to the database
MsgBox "Connected to Database"
Set cmd = New ADODB.Command
cmd.ActiveConnection = con 'Set up our command object for exceuting SQL statement
cmd.CommandText = pInsQry
cmd.CommandType = adCmdText

cmd.Parameters.Append cmd.CreateParameter("iPDRID", adVarChar, adParamInput, 25)
cmd.Parameters.Append cmd.CreateParameter("iManagerID", adVarChar, adParamInput, 15)
cmd.Parameters.Append cmd.CreateParameter("iManager", adVarChar, adParamInput, 50)
cmd.Parameters.Append cmd.CreateParameter("iPayID", adVarChar, adParamInput, 15)
cmd.Parameters.Append cmd.CreateParameter("iEmpName", adVarChar, adParamInput, 50)
cmd.Parameters.Append cmd.CreateParameter("iPDRDate", adDate, adParamInput)
cmd.Parameters.Append cmd.CreateParameter("iCreateDate", adDate, adParamInput)
cmd.Parameters.Append cmd.CreateParameter("iKPI1Val", adNumeric, adParamInput)
cmd.Parameters.Append cmd.CreateParameter("iKPI1Score", adCurrency, adParamInput)
cmd.Parameters.Append cmd.CreateParameter("iKPI2Val", adNumeric, adParamInput)
cmd.Parameters.Append cmd.CreateParameter("iKPI2Score", adCurrency, adParamInput)
cmd.Parameters.Append cmd.CreateParameter("iKPI3Val", adNumeric, adParamInput)
cmd.Parameters.Append cmd.CreateParameter("iKPI3Score", adCurrency, adParamInput)
cmd.Parameters.Append cmd.CreateParameter("iKPI4Val", adNumeric, adParamInput)
cmd.Parameters.Append cmd.CreateParameter("iKPI4Score", adCurrency, adParamInput)
cmd.Parameters.Append cmd.CreateParameter("iPayment", adCurrency, adParamInput)

con.BeginTrans
On Error GoTo e2
With shtRng
For i = 0 To .Rows.Count - 1
cmd("iPDRID").Value = .Cells(i + 1, 1).Value
Debug.Print .Cells(i + 1, 1).Value
cmd("iManagerID").Value = .Cells(i + 1, 2).Value
cmd("iManager").Value = .Cells(i + 1, 3).Value
cmd("iPayID").Value = .Cells(i + 1, 4).Value
cmd("iEmpName").Value = .Cells(i + 1, 5).Value
cmd("iPDRDate").Value = VBA.DateTime.DateSerial(Year(.Cells(i + 1, 6).Value), Month(.Cells(i + 1, 6).Value), Day(.Cells(i + 1, 6).Value))
cmd("iCreateDate").Value = VBA.DateTime.DateSerial(Year(.Cells(i + 1, 7).Value), Month(.Cells(i + 1, 7).Value), Day(.Cells(i + 1, 7).Value))
cmd("iKPI1Val").Value = .Cells(i + 1, 8).Value
cmd("iKPIScore").Value = .Cells(i + 1, 9).Value
cmd("iKPI2Val").Value = .Cells(i + 1, 10).Value
cmd("iKPI2Score").Value = .Cells(i + 1, 11).Value
cmd("iKPI3Val").Value = .Cells(i + 1, 12).Value
cmd("iKPI3Score").Value = .Cells(i + 1, 13).Value
cmd("iKPI4Val").Value = .Cells(i + 1, 14).Value
cmd("iKPI4Score").Value = .Cells(i + 1, 15).Value
cmd("iPayment").Value = .Cells(i + 1, 16).Value
Debug.Print shtRng.Address
cmd.Execute Options:=adExecuteNoRecords
Next
End With
e2: If Err.Number Then
MsgBox Err.Description, vbCritical, "Error Submit Has Failed"
Err.Clear
blnCommit = False
submitPDRInfo = Err.Number
Else
blnCommit = True
submitPDRInfo = Err.Number
End If

On Error GoTo e1
If blnCommit Then con.CommitTrans Else con.RollbackTrans

e1: If Err.Number Then
MsgBox Err.Description, vbCritical, "Error Submit Has Failed"
submitPDRInfo = Err.Number
Err.Clear
End If
Set cmd = Nothing

If Not con Is Nothing Then
If Not con.State = adStateClosed Then con.Close
Set con = Nothing
End If
End Function
Private Sub cmdUpload_Click()
Dim currArcRow As Long
Dim lngRow As Long
Dim rngDataUpload As Range
Dim rngCurr As Range
Set rngCurr = Sheets("Uploaded").Range("A2:A65536")
Dim rngArc As Range
Dim lngIErr As Long ' adds all err numbers together. If no errors occur then this number is 0
Dim adoRSToArchive As ADODB.Recordset

currArcRow = Module1.findLastRow(rngCurr, "")
If adoRSToSend.RecordCount < 1 Then
MsgBox ("Currently Nothing To Upload")
Else
Dim optInt As Integer
optInt = MsgBox("Are You Sure You Want To Upload " & vbCrLf & vbCrLf & _
"You Cannot Make Any Changes To Uploaded Data.", vbYesNo, "Uploading Data")
If optInt = vbYes Then
lngRow = findLastRow(Sheets("ToSend").Range("A2"), "")
Set rngDataUpload = Sheets("ToSend").Range("A2Stick out tongue" + CStr(lngRow))
lngIErr = lngIErr + submitPDRInfo(rngDataUpload, "insert into tblPDR (PDRID,ManagerID,Manager,PayID,EmpName,PDRDate,CreateDate,KPI1Val,KPI1Score,KPI2Val,KPI2Score,KPI3Val,KPI3Score,KPI4Val,KPI4Score,Payment,SubmittedBy) Values ( , , , , , , , , , , , , , , , ,'" + fOSUserName() + "');")
If lngIErr <> 0 Then lngIErr = 1
' if no errors in upload move all data to archive
If lngIErr = 0 Then
Set rngDataUpload = Sheets("ToSend").Range("A2Stick out tongue" + CStr(lngRow))
Set rngArc = Sheets("Uploaded").Range("A" + CStr(currArcRow + 1))
rngDataUpload.Copy rngArc
rngDataUpload.ClearContents
Set adoRSToArchive = copyToRecordset(rngDataUpload)
rngDataUpload.Copy rngArc
rngDataUpload.ClearContents
Set adoRSToArchive = copyToRecordset(rngDataUpload)
MsgBox ("Data Uploaded")
Else
MsgBox ("Upload Has Failed")
End If
End If
End If
ThisWorkbook.Save
init
End Sub
Public Sub init()
Dim lngRow As Long
lngRow = findLastRow(Sheets("ToSend").Range("A2"), "") + 1
Set rangeObj = Sheets("ToSend").Range("A1Stick out tongue" + CStr(lngRow))
Set adoRSToSend = copyToRecordset(rangeObj)
Set rangeObj = Sheets("ToSend").Range("A1Stick out tongue" + CStr(lngRow))
Set adoRSToSend_ = copyToRecordset(rangeObj)
If adoRSToSend_.RecordCount <= 1 Then
Me.TextBox1 = 0
Else
Me.TextBox1 = adoRSToSend_.RecordCount
End If
lngRow = findLastRow(Sheets("ToSend").Range("A2"), "") + 1
lngRow = findLastRow(Sheets("Uploaded").Range("A2"), "") + 1
Set rangeObj = Sheets("Uploaded").Range("A1Stick out tongue" + CStr(lngRow))
Set adoRSSent = copyToRecordset(rangeObj)
Set rangeObj = Sheets("Uploaded").Range("A1Stick out tongue" + CStr(lngRow))
Set adoRSSent_ = copyToRecordset(rangeObj)
Set rngObjNew = ThisWorkbook.Sheets("Lookups").Range("A1").End(xlDown)
Set rangeObj = Sheets("Lookups").Range("A1:C" + CStr(rngObjNew.Row))
Set adoRSIM = copyToRecordset(rangeObj)
Set rngObjNew = Nothing
Set rngObjNew = ThisWorkbook.Sheets("Lookups").Range("E1").End(xlDown)
Set rangeObj = Sheets("Lookups").Range("E1:H" + CStr(rngObjNew.Row))
Set rngObjNew = Nothing
Set adoRSEngi = copyToRecordset(rangeObj)
End Sub





Re: Connecting to Access Database via ADO from Excel

ADG

Hi

Should

cmd("iKPIScore").Value = .Cells(i + 1, 9).Value

be

cmd("iKPI1Score").Value = .Cells(i + 1, 9).Value





Re: Connecting to Access Database via ADO from Excel

JezLisle

Excellent, thanks for that, me that cant type :-)

I have re run the code now and this time I get a different error....

Parameter _9 has no default value

Does this show because I want it to be Currency and that above the same line I had the spelling mistake I state that it should be adCurrency and adParameter

How can I get around this

Jez





Re: Connecting to Access Database via ADO from Excel

JezLisle

If I have assigned fields with a default setting on the table setup how is an error of Parameter has no default error occuring

I am really struggling with this, is the fact I want Currency in the cell a factor

Jez





Re: Connecting to Access Database via ADO from Excel

JezLisle

I am still struggling with this, has anyone any ideas

Jez