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
"Tom Ogilvy" wrote:
> http://www.erlandsendata.no/english/...php?t=envbadac
>
> --
> Regards,
> Tom Ogilvy
>
>
> "Jez" wrote:
>
> > 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?
Similar Threads
