Please see code below for parsing data from json into MS Access tables using VBA. The first level (Order) works fine, it's the second level (OrderLine) that is getting an error, and not quite sure how to get the OrderDetailID (which is an auto-number) from the first table into the second table to be able to link. I have been using some code i found online and replicated but something not quite right. I'm using the Tim Hall VBA-json parser.
First error is Data type conversion error on line rs!OrderDetailID = Order("OrderID"). If i leave that line out then i get error Wrong number of arguments or invalid property assignment on line arrValues = Split(OrderLine, ",").
Any help much appreciated. Thanks
Json data retrieved:
{"Order":
[{"ShipLastName":"Bloggs",
"ShipFirstName":"Joe",
"OrderID":"INV1324",
"OrderType":"sales",
"OrderLine":
[{"Quantity":"1",
"SKU":"9045200017",
"OrderLineID":"INV1324-0"}],
"DeliveryInstruction":"",
"ShipPhone":"+6491234567",
"Email":"joe.bloggs#somecompany.com",
"ShippingOption":"Standard Shipping",
"ShipCompany":"Some Company Ltd",
"ShipStreetLine1":"58 Some Street",
"ShipCity":"Some City",
"ShipState":"Some State",
"ShipCountry":"NZ",
"CustomerRef1":"",
"DatePlaced":"2021-06-03 22:26:48",
"OrderStatus":"Pick",
"ShipPostCode":"2103"}],
"CurrentTime":"2021-09-21 05:10:24",
"Ack":"Success"}
Option Compare Database
Option Explicit
Dim arrValues() As String
Dim I As Integer
--------------------------
Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim JsonText As Object
Dim Order As Variant
Dim OrderLine As Variant
'add order to tblOrderDetails
Set rs = db.OpenRecordset("tblOrderDetails", dbOpenDynaset, dbSeeChanges)
Set JsonText = JsonConverter.ParseJson(reader.responseText)
For Each Order In JsonText("Order")
rs.AddNew
rs!Date = Format(Now(), "dd/mm/yyyy")
rs!Time = Format(Now(), "hh:nn")
rs!ClientID = 123
rs!OrderNo = Order("OrderID")
rs!DelPhone = Order("ShipPhone")
rs!NotifyEmailAddress = Order("Email")
rs!DelName = Order("ShipCompany")
rs!DelStreet = Order("ShipStreetLine1")
rs!DelSuburb = Order("ShipCity")
rs!DelCity = Order("ShipState")
rs!DelZipCode = Order("ShipPostCode")
rs!DelCountryID = DLookup("CountryID", "tblCountries", "CountryCode = '" & Order("ShipCountry") & "'")
rs!DelContactName = Order("ShipFirstName") & " " & Order("ShipLastName")
rs.Update
Next Order
'add products to tblOrdersProd
Set rs = db.OpenRecordset("tblOrdersProd", dbOpenDynaset, dbSeeChanges)
Set JsonText = JsonConverter.ParseJson(reader.responseText)
For Each Order In JsonText("Order")
For Each OrderLine In Order("OrderLine")
rs.AddNew
rs!OrderDetailID = Order("OrderID")
arrValues = Split(OrderLine, ",")
For I = 0 To UBound(arrValues)
rs!Qty = arrValues(1)
rs!Productid = DLookup("ProductID", "tblProducts", "ProductCode = '" & OrderLine(arrValues(2)) & "'")
Next
rs.Update
Next OrderLine
Next Order
rs.Close
Here is my suggestion, you may need to adjust a bit to get it working...
Option Compare Database
Option Explicit
'//--------------------------
Dim db As DAO.Database
Dim rsOrderDetails As DAO.Recordset
Dim rsOrdersProd As DAO.Recordset
Dim JsonText As Object
Dim Order As Variant
Dim OrderLine As Variant
Dim newID as Long
'add order to tblOrderDetails
Set rsOrderDetails = db.OpenRecordset("tblOrderDetails", dbOpenDynaset, dbSeeChanges)
'add products to tblOrdersProd
Set rsOrdersProd = db.OpenRecordset("tblOrdersProd", dbOpenDynaset, dbSeeChanges)
Set JsonText = JsonConverter.ParseJson(reader.responseText)
For Each Order In JsonText("Order")
With rsOrderDetails
.AddNew
!Date = Format(Now(), "dd/mm/yyyy")
!Time = Format(Now(), "hh:nn")
!ClientID = 123
!OrderNo = Order("OrderID")
!DelPhone = Order("ShipPhone")
!NotifyEmailAddress = Order("Email")
!DelName = Order("ShipCompany")
!DelStreet = Order("ShipStreetLine1")
!DelSuburb = Order("ShipCity")
!DelCity = Order("ShipState")
!DelZipCode = Order("ShipPostCode")
!DelCountryID = DLookup("CountryID", "tblCountries", "CountryCode = '" & Order("ShipCountry") & "'")
!DelContactName = Order("ShipFirstName") & " " & Order("ShipLastName")
.Update
'// Now get the newly-allocated autonumber field
.Bookmark = .LastModified
newID = !OrderDetailID
End With
For Each OrderLine In Order("OrderLine")
With rsOrdersProd
.AddNew
'// Use the ID from the OrderDetails record
!OrderDetailID = newID
!Qty = OrderLine("Quantity")
!Productid = DLookup("ProductID", "tblProducts", "ProductCode = '" & OrderLine("SKU") & "'")
.Update
End With
Next OrderLine
Next Order
rsOrderDetails.Close
rsOrdersProd.Close
Related
I am running some code to split a slash-separated field into multiple rows, but the first value in the series is not carrying over. Does anyone know what I'm missing. Also, Rows that only have one record are not carrying over.
Public Sub ReformatTable()
Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim rsADD As DAO.Recordset
Dim strSQL As String
Dim strMPG, strBusinessName, strCustomerNumber, strCustomerName, strCountStartDate, strCCStatus As String
Dim strSplitMPG As String
Dim varData As Variant
Dim i As Integer
Set db = CurrentDb
' Select all eligible fields (have a comma) and unprocessed (SPLIT_MPG is Null)
strSQL = "SELECT BUSINESS_NAME, CUSTOMER_NUMBER, CUSTOMER_NAME, COUNT_START_DATE, CC_STATUS, MPG, SPLIT_MPG FROM [tmStarCycleCountStatuses_SlashesforCommas] WHERE ([MPG] Like ""*/*"") AND ([SPLIT_MPG] Is Null)"
Set rsADD = db.OpenRecordset("tmStarCycleCountStatuses_SlashesforCommas", dbOpenDynaset, dbAppendOnly)
Set rs = db.OpenRecordset(strSQL, dbOpenDynaset)
With rs
While Not .EOF
strMPG = !MPG
strBusinessName = !BUSINESS_NAME
strCustomerNumber = !CUSTOMER_NUMBER
strCustomerName = !CUSTOMER_NAME
strCountStartDate = !COUNT_START_DATE
strCCStatus = !CC_STATUS
varData = Split(strMPG, "/") ' Get all comma delimited fields
' Update First Record
.Edit
!SPLIT_MPG = Trim(varData(0)) ' remove spaces before writing new fields
.Update
' Add records with same first field
' and new fields for remaining data at end of string
For i = 1 To UBound(varData)
With rsADD
.AddNew
!MPG = strMPG
!SPLIT_MPG = Trim(varData(i)) ' remove spaces before writing new fields
!BUSINESS_NAME = strBusinessName
!CUSTOMER_NUMBER = strCustomerNumber
!CUSTOMER_NAME = strCustomerName
!COUNT_START_DATE = strCountStartDate
!CC_STATUS = strCCStatus
.Update
End With
Next
.MoveNext
Wend
.Close
rsADD.Close
End With
Set rsADD = Nothing
Set rs = Nothing
db.Close
Set db = Nothing
End Sub
I can't post images yet due to reputation constrictions, but here are some links.
Here's the multiple after the code:
https://s9.postimg.org/fn3u70b5b/Multiple.jpg
Here's the single records after code run:
https://s10.postimg.org/bfq9z4snt/Singles.jpg
I feel like there's something super simple that I'm missing here, but it looks like I'm already taking the MPG over, so i'm curious as to why I'm not getting the singles or the first of the series. Any help would be appreciated! Thank you.
It looks right to me, except that you have to declare like this:
Dim strMPG As String
Dim strBusinessNames As String
Dim strCustomerNumbers As String
Dim strCustomerNames As String
Dim strCountStartDates As String
Dim strCCStatus As String
I guess you will have to insert some lines with Debug.Print .. to narrow down the happenings.
Got it. Ended up changing my approach. This code will work. The pattern, regardless of length, would always be the same, so I used a Right/Left combo and integers
Public Sub ReformatmStarCycleCountStatusesTable()
Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim strSQL As String
Dim strMPG As String
Dim strBusinessName As String
Dim strCustomerNumber As String
Dim strCustomerName As String
Dim dteCountStartDate As Date
Dim strCCStatus As String
Dim strSplitMPG As String
Dim intRemainingLength As Integer
Dim intInitialLength As Integer
Dim intStartPoint As Integer
Dim varData As Variant
Set db = CurrentDb
DoCmd.SetWarnings False
' Select all eligible fields (have a comma)
strSQL = "SELECT * FROM [mStar Cycle Count Statuses] WHERE [PRODUCT_FILTER_VALUE] is not null"
Set rs = db.OpenRecordset(strSQL, dbOpenDynaset)
With rs
While Not .EOF
strMPG = !PRODUCT_FILTER_VALUE
strBusinessName = !BUSINESS_NAME
strCustomerNumber = !CUSTOMER_NUMBER
dteCountStartDate = !COUNT_START_DATE
strCCStatus = !Status
intInitialLength = Len(strMPG)
intRemainingLength = intInitialLength
intStartPoint = 2
Do While intRemainingLength > 0
strSQL = "INSERT INTO tmStarCycleCountStatuses VALUES ('" & strBusinessName & "', '" & strCustomerNumber _
& "', #" & dteCountStartDate & "#, '" & strCCStatus & "', '" & Right(Left(strMPG, intStartPoint), 2) & "')"
DoCmd.RunSQL (strSQL)
intStartPoint = intStartPoint + 3
intRemainingLength = intRemainingLength - 3
Loop
intStartPoint = 1
.MoveNext
Wend
.Close
End With
DoCmd.SetWarnings True
Set rs = Nothing
db.Close
Set db = Nothing
End Sub
I can't work out where I am going wrong with my code. When the user selects a value in the combo box, i want it to go to the Consultants table and grab the default rate for that consultant and stick it in the Hourly Rate text box. This is the msg that I get when I update the combobox.
Private Sub cmbConsultant_Change()
Dim db As Database
Dim rs As DAO.Recordset ''Requires reference to Microsoft DAO x.x Library
Dim strSQL As String
strSQL = "defaultFee * FROM tblConsultants WHERE ID = """ & Me!cmbConsultant & """"
Set db = CurrentDb
Set rs = db.OpenRecordset(strSQL)
If rs.RecordCount > 0 Then
Me.txtHourlyRate = rs!CountOfEndDeviceType
Else
Me.txtHourlyRate = ""
End If
Set rs = Nothing
Set db = Nothing
End Sub
You could use DLookup for this - much simpler:
Private Sub cmbConsultant_Change()
Me!txtHourlyRate.Value = DLookup("defaultFee", "tblConsultants", "ID = '" & Me!cmbConsultant.Value & "'")
End Sub
However, most likely your ID is numeric, thus:
Private Sub cmbConsultant_Change()
Me!txtHourlyRate.Value = DLookup("defaultFee", "tblConsultants", "ID = " & Me!cmbConsultant.Value & "")
End Sub
I Think You need some SELECT Here
strSQL = "defaultFee * FROM tblConsultants WHERE ID = """ & Me!cmbConsultant & """"
It Should Be:
strSQL = "SELECT defaultFee AS [CountOfEndDeviceType] FROM tblConsultants WHERE ID = """ & Me!cmbConsultant & """"
Also Note, That [CountOfEndDeviceType] Must be a FieldName, SO I've put it in a Select statement.
Please forgive the sloppy coding, but I was thrown onto a project to get data from a spreadsheet to SQL server and the deadline has been missed. I was able to initial get my first dataswipe using a SELECT statement, but I can't seem to switch it over to an UPDATE.
Here's the code. I get the runtime error 3704 operation not allowed when object is closed at the line rstRecordset.AddNew
Public cnnConn As ADODB.Connection
Public rstRecordset As ADODB.Recordset
Public cmdCommand As ADODB.Command
Public Const Server As String = "datguy"
Public SQLQuery As String
Option Explicit
Sub testupinsertupdate()
Dim wkb As Workbook
Dim wks As Worksheet
Dim sel As Range
Set wkb = ActiveWorkbook
Set wks = Sheets(1)
Set sel = Selection
With wks
'Declaration unit
Dim dataitem As String
Dim yr As Integer
Dim yrmax As Integer
Dim rxcount As Integer
Dim row As Integer
Dim col As String
Dim cleanup As String
Dim sqlrxcount As String
dataitem = .Range("B3").Value
yr = 6 'data only needs to go back to 2006
yrmax = .Range("C7").End(xlToRight).row + yr 'declarative count to the Right-Of-File
rxcount = 7
row = .Range("A" & .Rows.Count).End(xlUp).row 'declarative count to EOF
col = .Range("C6").End(xlToRight).Column
cleanup = "Data Unavailable"
sqlrxcount = .Range("A" & rxcount).Value
Set cnnConn = New ADODB.Connection
cnnConn.ConnectionString = "driver={SQL Server};server=" & Server & ";database=database;Trusted_Connection=Yes"
cnnConn.ConnectionTimeout = 800
cnnConn.Open
For rxcount = 7 To row
Set cmdCommand = New ADODB.Command
Set cmdCommand.ActiveConnection = cnnConn
With cmdCommand
.CommandTimeout = 0
.CommandText = "UPDATE table SET " & dataitem & " = '" & Cells(col).Value & "' WHERE RX_ID = '" & sqlrxcount & "'"
.CommandType = adCmdText
.Execute
Debug.Print cmdCommand.State
End With
Debug.Print cmdCommand.State
Set rstRecordset = New ADODB.Recordset
Set rstRecordset.ActiveConnection = cnnConn
rstRecordset.Open cmdCommand, , adOpenStatic, adLockBatchOptimistic
col = ("C" & rxcount)
For yr = 6 To yrmax
rstRecordset.AddNew '*** error pops!
rstRecordset.Fields("RX_ID") = Range("A" & rxcount).Value
rstRecordset.Fields("YEAR_REPORTED") = yr + 2000
If Range(col).Value = cleanup Then
rstRecordset.Fields(dataitem) = Null
Else: rstRecordset.Fields(dataitem) = Range(col).Value
End If
'debug line to show results
Debug.Print Range("A" & rxcount).Value, yr + 2000, Range(col).Value
col = Range(col).Offset(0, 1).Address
Next yr
Next rxcount
rstRecordset.UpdateBatch
rstRecordset.Close
cnnConn.Close
End With
End Sub
I don't feel like I'm doing the operations in order, but I'm just trying to get the initial load and then will worry about maintenance later. Why isn't the object(I assume this is the recordset) open when it was opened three lines before?
You are attempting to open a recordset based on an update not a select
rstRecordset.Open cmdCommand, , adOpenStatic, adLockBatchOptimistic
should be something like
rstRecordset.Open "select * from table",cnnconn, adOpenStatic, adLockBatchOptimistic
This is my code and I can save only the first item. I need to save the entire list in one database column. Thanks for your help in advance.
Dim mysql As String = "UPDATE tbl_item SET my_item = (#myitems) WHERE id = '" & Label6.Text & "'"
Dim mycmd As New MySqlCommand(mysql, sConnection)
Dim values As New List(Of String)
values.Add(ListBox1.Items.Add(values))
Dim sqlParam As New MySqlParameter With {.ParameterName = "#myitems", .DbType = DbType.String}
mycmd.Parameters.Add(sqlParam)
Dim i As Integer
For i = 0 To values.Count - 1
sqlParam.Value = (ListBox1.Items(i) & ";")
mycmd.ExecuteNonQuery()
Next
Dim i As Integer
For i = 0 To values.Count - 1
If sqlparam.value = "" Then
sqlparam.value = listbox1.Items(i) & ";"
Else
sqlparam.value = sqlparam.value & listbox.Items(i) & ";"
End If
Next
mycmd.ExecuteNonQuery()
If this code failed, then try to put mycmd.execute.... inside..
I need a code where the user (after pasting data in a datasheet), when he clicks a button, the data will be inserted in a table (I was thinking of using an SQL statement here). In addition to that, one of the fields in that table will have to be calculated using the DCount function. So I need to calculate that per record. Let me know if the idea is not clear and I need to explain further. Also, if there are better ideas out there, do tell. Thanks!
Why not create some VBA to pull in the data from the spreadsheet, insert it into the table and then close down excel again. All in a button click
Take a look at the below for an example
Dim objApp As Excel.Application
Dim objBook As Excel.Workbook
Dim objSheet As Excel.Worksheet
Dim sSQL As String
Dim Path As String
Set db = CurrentDb()
Set objBook = Workbooks.Add(Template:=SheetLocation) 'Your excel spreadsheet file goes here where "SheetLocation is typed
Set objApp = objBook.Parent
Set objSheet = objBook.Worksheets("Sheet1") 'Name of sheet you want to View
objBook.Windows(1).Visible = True
objApp.Visible = True
objApp.DisplayAlerts = False
Dim cn As ADODB.Connection, rs As ADODB.Recordset, r As Long
' connect to the Access database
Set cn = CurrentProject.Connection
' open a recordset
Set rs = New ADODB.Recordset
rs.Open "INSERT YOUR TABLE NAME HERE", cn, adOpenKeyset, adLockOptimistic, adCmdTable
' all records in a table
r = 2 ' the start row in the worksheet
Do While Len(Range("A" & r).Formula) > 0
' repeat until first empty cell in column A
With rs
.AddNew ' create a new record
' add values to each field in the record
.Fields("INSERT THE TABLE FIELD TO DUMP DATA IN HERE") = Range("A" & r).Value
.Fields("REPEAT AS ABOVE") = Range("B" & r).Value
.Fields("REPEAT AS ABOVE") = Range("C" & r).Value
.Fields("REPEAT AS ABOVE") = Range("D" & r).Value
.Fields("REPEAT AS ABOVE") = Range("E" & r).Value
.Fields("REPEAT AS ABOVE") = Range("F" & r).Value
.Fields("REPEAT AS ABOVE") = Range("G" & r).Value
.Fields("REPEAT AS ABOVE") = Range("H" & r).Value
' add more fields if necessary...
.Update ' stores the new record
End With
r = r + 1 ' next row
Loop
rs.Close
Set rs = Nothing
cn.Close
Set cn = Nothing
objApp.Quit