ADO from Excel to Access

[Guest]

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?

 

[David Sisson]

http://www.erlandsendata.no/english/index.php?d=envbadacexportado

 

[Guest]

http://www.erlandsendata.no/english/index.php?t=envbadac

 

[Guest]

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

The 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?

Line: cmd("iKPI1Score").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("iKPI1Score").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("A2" + 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("A2" + 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("A1" + CStr(lngRow))
Set adoRSToSend = copyToRecordset(rangeObj)
Set rangeObj = Sheets("ToSend").Range("A1" + 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("A1" + CStr(lngRow))
Set adoRSSent = copyToRecordset(rangeObj)
Set rangeObj = Sheets("Uploaded").Range("A1" + 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

 

[Guest]

David, Thanks for the website, I have tried it and for some reason doesnt
send any data to the table I want it to. It seems to make connection and tell
me that it has uploaded the data, but when checking it, the table in Access
is still empty.

Not sure what I have done wrong. Ignore the previous thread as I was trying
something else that doesnt work at all.

This is the code I have tried.

Code A
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", vbCritical, "Uploading Data"
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("A2" + 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("A2" + 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", vbInformation, "Uploading Data"
Else
MsgBox "Upload Has Failed", vbCritical, "Uploading Data"
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("A1" + CStr(lngRow))
Set adoRSToSend = copyToRecordset(rangeObj)
Set rangeObj = Sheets("ToSend").Range("A1" + 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("A1" + CStr(lngRow))
Set adoRSSent = copyToRecordset(rangeObj)
Set rangeObj = Sheets("Uploaded").Range("A1" + 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

Code B

Function submitPDRInfo(shtRng As Range, pInsQry As String) As Long
Dim con As ADODB.Connection, rs As ADODB.Recordset, r As Long
' connect to the Access database
Set con = New ADODB.Connection
con.Open "Provider=Microsoft.Jet.OLEDB.4.0; " & _
"Data Source=D:\Work\BonusMatrix\BonusReviews.mdb;"
' open a recordset
Set rs = New ADODB.Recordset
rs.Open "tblPDR", con, adOpenKeyset, adLockOptimistic, adCmdTable
' all records in a table
r = 2 ' the start row in the worksheet
Do While Len(Range("A" & r).Value) > 0
' repeat until first empty cell in column A
With rs
.AddNew ' create a new record
.Fields("PDRID") = Range("A" & r).Value
.Fields("ManagerID") = Range("B" & r).Value
.Fields("Manager") = Range("C" & r).Value
.Fields("PayID") = Range("D" & r).Value
.Fields("EmpName") = Range("E" & r).Value
.Fields("PDRDate") = Range("F" & r).Value
.Fields("CreateDate") = Range("G" & r).Value
.Fields("KPI1Val") = Range("H" & r).Value
.Fields("KPI1Score") = Range("I" & r).Value
.Fields("KPI2Val") = Range("J" & r).Value
.Fields("KPI2Score") = Range("K" & r).Value
.Fields("KPI3Val") = Range("L" & r).Value
.Fields("KPI3Score") = Range("M" & r).Value
.Fields("KPI4Val") = Range("N" & r).Value
.Fields("KPI4Score") = Range("O" & r).Value
.Fields("Payment") = Range("P" & r).Value
.Fields("SubmittedBy") = Value.fOSUserName()
.Update ' stores the new record
End With
r = r + 1 ' next row
Loop
rs.Close
Set rs = Nothing
con.Close
Set con = Nothing
End Function

I cant see where its going wrong, How can I fix this? or even make it far
simpler. My main objective is that I have a userform in excel and on there is
a button which i want to click and then that sends data previously saved in
the report to a database for storage.

Jez