Insert Multiple Rows into Access Database though Excel VBA

[chacha123]

Dear all,

I have a question for how to insert multiple rows into Access Database though Excel VBA

Eg: The below is the order form.

( RED is compulsory field to insert into database)

[TABLE="width: 500"]
<tbody>[TR]
[TD]Name[/TD]
[TD] abc[/TD]
[TD][/TD]
[TD]Phone Number[/TD]
[TD]102-630000[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]IC No[/TD]
[TD]6363254A[/TD]
[TD][/TD]
[TD]Email[/TD]
[TD]abc@gmail.com[/TD]
[TD][/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]
[TABLE="class: grid, width: 500"]
<tbody>[TR]
[TD]Item No[/TD]
[TD]Product Description[/TD]
[TD]Discount Price[/TD]
[TD]QTY[/TD]
[TD]Amount[/TD]
[/TR]
[TR]
[TD]123[/TD]
[TD]Apple[/TD]
[TD]2.50[/TD]
[TD]1[/TD]
[TD]2.50[/TD]
[/TR]
[TR]
[TD]1234[/TD]
[TD]Orange[/TD]
[TD]3.00[/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]12345[/TD]
[TD]Grapes[/TD]
[TD]5.00[/TD]
[TD]2[/TD]
[TD]10.00[/TD]
[/TR]
[TR]
[TD]123456[/TD]
[TD]Lemon[/TD]
[TD]2.00[/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]1234567[/TD]
[TD]Avocado[/TD]
[TD]4.00[/TD]
[TD]1[/TD]
[TD]4.00[/TD]
[/TR]
</tbody>[/TABLE]

For the field Item No, Product Description, Discount Price, QTY and Amount insert when the QTY is not null.

Private Sub cmdSubmitOrder_Click()
Dim cn As ADODB.Connection, rs As ADODB.Recordset
Dim sName As String, sNricno As String, sContactno As String, sEmail As String, sItemNo As String, sProdD As String, sDiscP As String, sQty As String, sAmount As String
Dim msg As String, title As String


Set cn = New ADODB.Connection
cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;" & _
        "Data Source=abc.mdb;"


Set rs = New ADODB.Recordset
rs.Open "STAFFORDER", cn, adOpenKeyset, adLockOptimistic, adCmdTable


'Range("A2").Activate
'Do While Not IsEmpty(ActiveCell)
sName = Cells(1, 2).Value
sNricno = Cells(2, 2).Value
sContactno = Cells(1, 5).Value
sDept = Cells(2, 5).Value


sBprcode = Range("A:A").Value
sProdD = Range("B:B").Value
sDiscP = Range("C:C").Value
sQty = Range("D:D").Value
sAmount = Range("E:E").Value


rs.Filter = "NAME='" & sName & "'"
If rs.EOF Then
Debug.Print "No existing record - adding new..."
rs.Filter = ""
rs.AddNew
rs("NAME").Value = sName
rs("NRICNO").Value = sNricno
rs("CONTACTNO").Value = sContactno
rs("EMAIL").Value = sEmail
Dim cell As Range
For Each cell In Range("D:D")
If cell.Value = vbNullString Then
rs("BPRCODE").Value = ""
rs("PRODDESC").Value = ""
rs("DISCPRICE").Value = ""
rs("QTY").Value = ""
rs("AMOUNT").Value = ""
Else
rs("BPRCODE").Value = sBprcode
rs("PRODDESC").Value = sProdD
rs("DISCPRICE").Value = sDiscP
rs("QTY").Value = sQty
rs("AMOUNT").Value = sAmount
End If
Next cell
Else
MsgBox "Existing record found..", vbExclamation, "Info"
'Debug.Print "Existing record found..."
End If
Dim cell2 As Range
For Each cell2 In Range("D:D")
If cell2.Value = vbNullString Then
rs("BPRCODE").Value = ""
rs("PRODDESC").Value = ""
rs("DISCPRICE").Value = ""
rs("QTY").Value = ""
rs("AMOUNT").Value = ""
Else
rs("BPRCODE").Value = sBprcode
rs("PRODDESC").Value = sProdD
rs("DISCPRICE").Value = sDiscP
rs("QTY").Value = sQty
rs("AMOUNT").Value = sAmount
End If
Next cell2

rs.Update
MsgBox "...record update complete.", vbExclamation, "Info"
'Debug.Print "...record update complete."




rs.Close
Set rs = Nothing
cn.Close
Set cn = Nothing
End Sub

Database Structure

[TABLE="class: grid, width: 500"]
<tbody>[TR]
[TD]Field Name [/TD]
[TD]Data Type[/TD]
[/TR]
[TR]
[TD]ORDERID[/TD]
[TD]AUTONUMBER[/TD]
[/TR]
[TR]
[TD]STAFFID[/TD]
[TD]NUMBER[/TD]
[/TR]
[TR]
[TD]NAME[/TD]
[TD]TEXT[/TD]
[/TR]
[TR]
[TD]NRICNO[/TD]
[TD]TEXT[/TD]
[/TR]
[TR]
[TD]CONTACTNO[/TD]
[TD]TEXT[/TD]
[/TR]
[TR]
[TD]EMAIL[/TD]
[TD]TEXT
[/TD]
[/TR]
[TR]
[TD]ITEMCODE[/TD]
[TD]NUMBER[/TD]
[/TR]
[TR]
[TD]PRODDESC[/TD]
[TD]TEXT[/TD]
[/TR]
[TR]
[TD]DISCPRICE[/TD]
[TD]CURRENCY[/TD]
[/TR]
[TR]
[TD]QTY[/TD]
[TD]NUMBER[/TD]
[/TR]
[TR]
[TD]AMOUNT[/TD]
[TD]CURRENCY[/TD]
[/TR]
</tbody>[/TABLE]


I had try use this code, but it seem like can't work.

I need your help. Thanks

 

[chacha123]

Hi Charles

This is the new table i create to store the order per line

ORDERITEM

[TABLE="class: grid, width: 500"]
<tbody>[TR]
[TD]Field Name[/TD]
[TD]Data Type[/TD]
[/TR]
[TR]
[TD]ORDERITEMID[/TD]
[TD]AUTONUMBER[/TD]
[/TR]
[TR]
[TD]ORDERID[/TD]
[TD]TEXT[/TD]
[/TR]
[TR]
[TD]BPRCODE[/TD]
[TD]NUMBER[/TD]
[/TR]
[TR]
[TD]QTY[/TD]
[TD]NUMBER[/TD]
[/TR]
[TR]
[TD]AMOUNT[/TD]
[TD]CURRENCY[/TD]
[/TR]
</tbody>[/TABLE]

I can enter the new item, but i couldn't update the item.

Private Sub cmdSubmitOrder_Click()
Dim cn As ADODB.Connection, rs As ADODB.Recordset
Dim msg As String, title As String
Dim MyCell As Range
Dim RecAddCt As Long
Dim RecUpdCt As Long
Dim RangeDepth As Range
Dim sid As String
'Dim sBprcode As String


'sid = Cells(7, 8).Value & Cells(5, 8).Value
Set cn = New ADODB.Connection
cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;" & _
        "Data Source=abc.mdb;"
RecAddCt = 0
RecUpdCt = 0
Set rs = New ADODB.Recordset
rs.Open "ORDERITEM", cn, adOpenKeyset, adLockOptimistic, adCmdTable
Set RangeDepth = Range("H12:H" & Cells(Rows.Count, "H").End(xlUp).Row)


For Each MyCell In RangeDepth
sid = MyCell.Offset(0, -7).Value
'sBprcode = MyCell.Offset(0, -6).Value
'rs.Filter = "ORDERID='" & sid & "' And BPRCODE='" & sBprcode & "'"
'If rs.EOF Then
If MyCell.Value <> vbNullString Then
rs.AddNew
rs("ORDERID").Value = sid
'rs("STAFFID").Value = Cells(5, 8).Value
'rs("NAME").Value = Cells(3, 4).Value
'rs("NRICNO").Value = Cells(5, 4).Value
'rs("CONTACTNO").Value = Cells(7, 4).Value
'rs("DEPT").Value = Cells(3, 8).Value
'rs("MONTH").Value = Cells(7, 8).Value
rs("BPRCODE").Value = MyCell.Offset(0, -6).Value
'rs("PRODDESC").Value = MyCell.Offset(0, -4).Value
'rs("DISCPRICE").Value = MyCell.Offset(0, -1).Value
rs("QTY").Value = MyCell.Offset(0, 0).Value
rs("AMOUNT").Value = MyCell.Offset(0, 1).Value
RecAddCt = RecAddCt + 1
rs.Update
'End If
Else
If MyCell.Value <> vbNullString Then
'rs.EditMode
rs("BPRCODE").Value = MyCell.Offset(0, -6).Value
'rs("PRODDESC").Value = MyCell.Offset(0, -4).Value
'rs("DISCPRICE").Value = MyCell.Offset(0, -1).Value
rs("QTY").Value = MyCell.Offset(0, 0).Value
rs("AMOUNT").Value = MyCell.Offset(0, 1).Value
RecUpdCt = RecUpdCt + 1
rs.Update
End If


'MsgBox RecCt & "New Records Added", vbExclamation, "Info"
'Else
'Debug.Print "Existing record found..."




'End If
'rs("BPRCODE").Value = MyCell.Offset(0, -6).Value
'rs("PRODDESC").Value = MyCell.Offset(0, -4).Value
'rs("DISCPRICE").Value = MyCell.Offset(0, -1).Value
'rs("QTY").Value = MyCell.Offset(0, 0).Value
'rs("AMOUNT").Value = MyCell.Offset(0, 1).Value


End If
Next MyCell
MsgBox RecAddCt & "New Records Added and " & RecUpdCt & "Records Updated", vbExclamation, "Info"




rs.Close
Set rs = Nothing
cn.Close
Set cn = Nothing
End Sub