I created a VBA code that enables me to get a string from a website. The string looks like that (json format)
[
{
"CD":151,
"nID":111,
"sNM":"PNAME1",
"GDR":"MA",
"RGN":"MM",
"reID":1,
"status":"RSB",
"NTY":"EG",
"CLNUM":1,
"CLNM":"THIR",
"YER":2022,
"SCHOD":1718,
"STID":2,
"THNM":"BRYYY",
"SCHNO":"HTBAN",
"rCD":6,
"schooL_TYPE":1,
"SGT":1,
"CLCD":3,
"NG1":1,
"NG2":2,
"YCOD":null,
"general":10,
"special":1,
"naT_ID":1,
"GDR_ID":1,
"sGCOD":8,
"sTTY":1,
"obNM":"NTF",
"obID":0,
"STYN":"NTHMY",
"PSNUM":null
},
{
"CD":153,
"nID":222,
"sNM":"ALIIKK",
"GDR":"MA",
"RGN":"MM",
"reID":1,
"status":"RSB",
"NTY":"EG",
"CLNUM":1,
"CLNM":"THIR",
"YER":2022,
"SCHOD":1718,
"STID":2,
"THNM":"SYYYYY",
"SCHNO":"HTBAN",
"rCD":6,
"schooL_TYPE":1,
"SGT":1,
"CLCD":3,
"NG1":1,
"NG2":2,
"YCOD":null,
"general":10,
"special":1,
"naT_ID":1,
"GDR_ID":1,
"sGCOD":8,
"sTTY":1,
"obNM":"NTF",
"obID":0,
"STYN":"NTHMY",
"PSNUM":null
}
]
I am trying to store the data into a collection and arrays
This is my try but I am confused about the line of setting the collection
Dim json As Object, col As Collection
Set json = JSONConverter.ParseJson(sResp)
Set col = json("CD")
Dim a, i As Long
ReDim a(1 To col.Count, 1 To 1)
For i = 1 To col.Count
'a(i, 1) = col.Item(i)("")
Next i
The string should have two persons' data. How can I pares all the data included into two rows?
I got an error Dictionary Key Not Found at this line of JSONConverter module
Option Explicit
Sub demo()
Dim sResp
sResp = "[{'CD':151,'nID':111,'sNM':'PNAME1','GDR':'MA','RGN':'MM','reID':1,'status':'RSB','NTY':'EG','CLNUM':1,'CLNM':'THIR','YER':2022,'SCHOD':1718,'STID':2,'THNM':'BRYYY','SCHNO':'HTBAN','rCD':6,'schooL_TYPE':1,'SGT':1,'CLCD':3,'NG1':1,'NG2':2,'YCOD':null,'general':10,'special':1,'naT_ID':1,'GDR_ID':1,'sGCOD':8,'sTTY':1,'obNM':'NTF','obID':0,'STYN':'NTHMY','PSNUM':null},{'CD':153,'nID':222,'sNM':'ALIIKK','GDR':'MA','RGN':'MM','reID':1,'status':'RSB','NTY':'EG','CLNUM':1,'CLNM':'THIR','YER':2022,'SCHOD':1718,'STID':2,'THNM':'SYYYYY','SCHNO':'HTBAN','rCD':6,'schooL_TYPE':1,'SGT':1,'CLCD':3,'NG1':1,'NG2':2,'YCOD':null,'general':10,'special':1,'naT_ID':1,'GDR_ID':1,'sGCOD':8,'sTTY':1,'obNM':'NTF','obID':0,'STYN':'NTHMY','PSNUM':null}]"
sResp = Replace(sResp, "'", Chr(34))
Dim data As Object, rec As Object, key, fields, arData
Dim n As Long, m As Long, i As Long, j As Long
Set data = JsonConverter.ParseJson(sResp)
fields = data(1).Keys
m = UBound(fields) + 1
n = data.Count ' records
' fill array
ReDim arData(1 To n, 1 To m)
For i = 1 To n
For j = 1 To m
arData(i, j) = data(i)(fields(j - 1))
Next
Next
' dump array
With Sheet1
.Range("A1").Resize(1, m) = fields ' header
.Range("A2").Resize(n, m) = arData
End With
End Sub
I was wrong. The converter also accepts square brackets as the first element, a collection. The suggested additional brackets would not work either, because they create an invalid JSON.
Now CDP1802 has already answered, but I also looked for a correct solution because of my wrong statement (I deleted it so no one else would see it as the truth):
Sub TestJSON()
Dim sResp As String
Dim json As Collection
Dim col As Dictionary
Dim key As Variant
Dim dicts As Long
Dim row As String
sResp = "[{""CD"":151,""nID"":111,""sNM"":""PNAME1"",""GDR"":""MA"",""RGN"":""MM"",""reID"":1,""status"":""RSB"",""NTY"":""EG"",""CLNUM"":1,""CLNM"":""THIR"",""YER"":2022,""SCHOD"":1718,""STID"":2,""THNM"":""BRYYY"",""SCHNO"":""HTBAN"",""rCD"":6,""schooL_TYPE"":1,""SGT"":1,""CLCD"":3,""NG1"":1,""NG2"":2,""YCOD"":null,""general"":10,""special"":1,""naT_ID"":1,""GDR_ID"":1,""sGCOD"":8,""sTTY"":1,""obNM"":""NTF"",""obID"":0,""STYN"":""NTHMY"",""PSNUM"":null},{""CD"":153,""nID"":222,""sNM"":""ALIIKK"",""GDR"":""MA"",""RGN"":""MM"",""reID"":1,""status"":""RSB"",""NTY"":""EG"",""CLNUM"":1,""CLNM"":""THIR"",""YER"":2022,""SCHOD"":1718,""STID"":2,""THNM"":""SYYYYY"",""SCHNO"":""HTBAN"",""rCD"":6,""schooL_TYPE"":1,""SGT"":1,""CLCD"":3,""NG1"":1,""NG2"":2,""YCOD"":null,""general"":10,""special"":1,""naT_ID"":1,""GDR_ID"":1,""sGCOD"":8,""sTTY"":1,""obNM"":""NTF"",""obID"":0,""STYN"":""NTHMY"",""PSNUM"":null}]"
Set json = JsonConverter.ParseJson(sResp)
For dicts = 1 To json.Count
Set col = json(dicts)
For Each key In col.Keys()
'Debug.Print key & ":" & col(key) & ", "
row = row & col(key) & Chr(9)
Next key
Debug.Print row
row = ""
Next dicts
End Sub
Related
I am new to VBA macro and need some experts help on meeting the below requirement.
I got a workbook containing 2 sheets called 'Data' and 'Stats'.
'Data' contains the values as below
'Stats' contains the values as below
On click on the button, I would like to do the below
Get the values in column A in 'Stats' sheet
Find all the matching rows in 'Data' Sheet
Find the smallest start time and put that in 'Stats' sheet against the stage value
Find the biggest end time and that in 'Stats' sheet against the stage value
Final output would be like below
Note: I do not have the MINIFS or MAXIFS in my installation.
Incase you dont have MINIFS and MAXIFS you can use array formulas like so:
={MIN(IF(Stats!A1=Data!$A$1:$A$1000,Data!$C$1:$C$1000))}
and
={MAX(IF(Stats!A1=Data!$A$1:$A$1000,Data!$B$1:$B$1000))}
The {} indicates, that this is a Array-Formula. Enter with Ctrl + Shift + Enter
No VBA needed.
Just use in your Stats worksheet the following formula for Start:
=MINIFS(Data!A:A,Data!C:C,Stats!A:A)
and the following for End:
=MAXIFS(Data!B:B,Data!C:C,Stats!A:A)
Please, the VBA solution, too. It will be very fast, using arrays, processing everything in memory and dropping the result at once:
Sub BringStats()
Dim shD As Worksheet, shS As Worksheet, lastRD As Long, lastRS As Long
Dim arrD, arrS, i As Long, k As Long, dict As Object, El As Variant
Set shD = Worksheets("Data")
Set shS = Worksheets("Stats")
lastRD = shD.Range("A" & rows.count).End(xlUp).row
lastRS = shS.Range("A" & rows.count).End(xlUp).row
arrD = shD.Range("A2:C" & lastRD).Value
arrS = shS.Range("A2:C" & lastRS).Value
Set dict = CreateObject("Scripting.dictionary")
'load the dictionary with unique keys and all corresponding date in a string, as item
For i = 1 To UBound(arrD)
If Not dict.Exists(arrD(i, 3)) Then
dict.Add arrD(i, 3), CDate(arrD(i, 1)) & ";" & CDate(arrD(i, 2))
Else
dict(arrD(i, 3)) = dict(arrD(i, 3)) & "|" & CDate(arrD(i, 1)) & ";" & CDate(arrD(i, 2))
End If
Next
Dim arr As Variant, minTime As Date, minPos As Long
For i = 1 To UBound(arrS)
If dict.Exists(arrS(i, 1)) Then
arr = Split(dict(arrS(i, 1)), "|") 'extract each pair of time stamps
If UBound(arr) > 0 Then
For Each El In arr 'extract the element containing minimum time
If minTime = 0 Then
minTime = TimeValue(Split(El, ";")(0)): minPos = k
Else
If TimeValue(Split(El, ";")(0)) < minTime Then minTime = TimeValue(Split(El, ";")(0)): minPos = k
End If
k = k + 1
Next
arrS(i, 2) = Split(arr(minPos), ";")(0): arrS(i, 3) = Split(arr(minPos), ";")(1) 'load the array with the minimum time correspondent values
Else
arrS(i, 2) = Split(dict(arrS(i, 1)), ";")(0): arrS(i, 3) = Split(dict(arrS(i, 1)), ";")(1)'loading the array in case of only one occurrence
End If
End If
minPos = 0: minTime = 0: k = 0 'reinitialize the used variables
Next i
'drop the processed array at once
shS.Range("A2").Resize(UBound(arrS), UBound(arrS, 2)).Value = arrS
End Sub
There can be a lot of the same 'stage' occurrences...
Dim txt As String
Dim i As Integer
Dim reference As Variant
Dim d As Integer
d = Worksheets("Sheet1").cells(Rows.Count, "a").End(xlUp).Row
txt = cells(3, 4).Value
reference = Split(txt, " ")
For i = 0 To UBound(reference)
cells(d + 1, [4]).Value = reference(i)
Next
txt = cells(3, 4).Value
reference = Split(txt, " ")
cells(d + 1, [12]).Value = reference(3)
Hi, im trying to pick the reference before the ubound value each time, and the copy to the reference to the last line. I got this code to work when its the 4th part of the string but im trying to always pick the value before the ubound. Is it possible to do UBOUND -1. or do i have to go another way around this. thanks max
There are basically 2 ways to pick the prelast value.
Option 1 - Using Ubound():
Sub TestMe()
Dim reference As String
reference = "Stack Overflow is my favourite VBA site!"
Dim splitted As Variant
splitted = Split(reference)
Debug.Print splitted(UBound(splitted) - 1)
End Sub
Option 2 - Using predefined function for array length and removing 2 from it:
Calling it this way:
Debug.Print splitted(GetArrayLength(splitted) - 2)
The function:
Private Function GetArrayLength(myArray As Variant) As Long
If IsEmpty(myArray) Then
GetArrayLength = 0
Else
GetArrayLength = UBound(myArray) - LBound(myArray) + 1
End If
End Function
The function is a bit better, because it checks for empty arrays.
I have a table that has 4 columns:
ID
keyword
Component
NewComponent
The first 3 contain data and the last one does not.
I have the data sorted by keyword then by component.
Looking at the image below:
Original Table:
Expected Result:
So as far as I can see, two loops need to be done:
Loop through keyword
While looping through keyword, loop through components and create new ones
This is the code I have so far, but I have confused myself with all the loops already..
Sub SingleColumnTable_To_Array()
Dim myTable As ListObject
Dim myArray As Variant
Dim x As Long
Dim compArr() As String, kwArr(), newArr()
Set tmpltWkbk = Workbooks("New DB.xlsm")
Set ws1 = tmpltWkbk.Sheets("TableSheet")
Set myTable = ws1.ListObjects("KW_Table")
counterOne = 0
myArray = myTable.DataBodyRange
kwCounter = 1
'keywords
For y = LBound(myArray) To UBound(myArray)
counterTwo = counterTwo + 1
ReDim Preserve kwArr(counterTwo)
kwArr(counterTwo) = myArray(y, 23)
Next y
RemoveDupesDict kwArr, newArr
'components
For x = LBound(myArray) To UBound(myArray)
counterOne = counterOne + 1
ReDim Preserve compArr(counterOne)
compArr(counterOne) = myArray(x, 3)
Next x
For Each kwElement In newArr
For Each compElement In compArr
Counter = 1
Do While kwCounter < Application.CountIf(kwArr, kwElement) + 1
'This is how I imagine I would create the new component name
'Selection.Offset(0, 1).Value = compElement & "." & Counter
Counter = Counter + 1
kwCounter = kwCounter + 1
Loop
End If
Next compElement
Next kwElement
End Sub
As per comment above. Expanded code slightly to add a new column to a table and insert the formula in case you want a VBA solution:
Sub x()
Dim t As ListObject
Set t = Sheets(1).ListObjects("Table1")
t.ListColumns.Add
t.ListColumns(t.DataBodyRange.Columns.Count).DataBodyRange.Formula = "=C2&"".""&COUNTIFS($B$2:B2,B2,$C$2:C2,C2)"
End Sub
I'd like to print nested dictionaries in VBA. Basically I have a Dictionary where every key is a String, but each value can either be a String or another Dictionary.
Say my Dictionary has got the value
{ "FOO" => "BAR" , "HELLO" => { "WORLD => ":)", "OTHER" => ":(" } }
I want to display in an Excel spreadsheet:
FOO |BAR |
HELLO|WORLD|:)
HELLO|OTHER|:(
My issue is that I need to find a way to guess what is the type of the value under each key, so when I call dict("HELLO") I can either display the value if it's a string or if it's a dictionary call the same function again.
In order to do so I need to know:
if there is a way to know what is the type of a value stored in a dictionary
if there is a way to cast that value to a target type (string or dictionary)
So here is what I've tried
Function display_dictionary(dict As Scripting.Dictionary, out As Range) As Integer
Dim vkey As Variant
Dim key As String
Dim row_offset As Integer
Dim value As Object
Dim svalue As String
Dim dvalue As Dictionary
Dim each_offset As Integer
row_offset = 0
For Each vkey In dict.Keys()
key = vkey
Set value = dict(key)
if value is String then
svalue = ???
out.offset(row_offset, 0).value = key
out.offset(row_offset, 1).value = svalue
row_offset = row_offset + 1
else if value is Dictionary
dvalue = ???
each_offset = display_dictionary(dvalue, out.offset(row_offset, 1))
For each_row = 0 To each_offset - 1
out.offset(row_offset + each_row) = key
Next
row_offset = row_offset + each_offset
End If
Next
End
I am actually going to propose a bit different way for displaying the results. I think it's more logical but you are welcome to modify it to suit your specific needs. Just as a hint print logical tree of nodes, like below, and then manipulate the results if ever needed.
So the tree would look like this for example (Note I added one more depth level)
and the code to reproduce
Private i As Long
Private depth As Long
Sub Main()
Cells.ClearContents
Dim dict As New Dictionary
Dim subDict As New Dictionary
Dim lvlDict As New Dictionary
lvlDict.Add "LVL KEY", "LVL ITEM"
subDict.Add "HELLO", ":)"
subDict.Add "WORLD", ":("
subDict.Add "OTHER", lvlDict
dict.Add "FOO", "BAR"
dict.Add "BOO", subDict
i = 1
depth = 0
TraverseDictionary dict
Columns.AutoFit
End Sub
Private Sub TraverseDictionary(d As Dictionary)
For Each Key In d.Keys
Range("A" & i).Offset(0, depth) = "KEY: " & Key
If VarType(d(Key)) = 9 Then
depth = depth + 1
TraverseDictionary d(Key)
Else
Range("B" & i).Offset(0, depth) = "ITEM: " & d(Key)
End If
i = i + 1
Next
End Sub
and spreadsheet result:
To get the variable type or its type name you can use this:
Debug.Print TypeName(dict("HELLO")), VarType(dict("HELLO"))
I have Dictionary objects Dic1,Dic2, whose Items are an alphabet. Say
Dic1(10)= A
Dic1(111)= B
Dic1(12)= C like this.
Dic2(125)= A
Dic2(131)= B
Dic2(126)= C like this.
Now I am trying to assign their keys through a loop in Excel row(3rd column onwards) by below,but not all keys are getting copied.
objSheet2.Range("C"&nRow).Value=Dic1.Keys() Or(condition wise any of the assignment
will be executed)
objSheet2.Range("C"&nRow).Value=Dic2.Keys()
But only the first Key value is getting copied,ignoring the other. Can you tell what the Bug is in my code?
Edit
Option Explicit
Class cP
Public m_sRel
Public m_dicC
Private Sub Class_Initialize()
m_sRel = "Child"
Set m_dicC = CreateObject("Scripting.Dictionary")
End Sub
Public Function show()
show = m_sRel & " " & Join(m_dicC.Keys)
End Function
End Class
Dim objSheet1,objSheet2,TotalRows,TotalcolCopy,strPathExcel1
'Dim oFS : Set oFS = CreateObject("Scripting.FileSystemObject")
Dim oXls : Set oXls = CreateObject("Excel.Application")
'Dim aData ': aData = oWb.Worksheets(1).Range("$A2:$C10")
Dim dicP : Set dicP = CreateObject("Scripting.Dictionary")
Dim nRow,nP,sKeys
strPathExcel1 = "D:\WIPData\AravoMacro\Finalscripts\A.xlsx"
oXls.Workbooks.open strPathExcel1
'oXls.Workbooks.Open(oFs.GetAbsolutePathName("A.xlsx"))
Set objSheet1 = oXls.ActiveWorkbook.Worksheets("WingToWingMay25")
Set objSheet2 = oXls.ActiveWorkbook.Worksheets("ParentChildLink")
TotalRows=oXls.Application.WorksheetFunction.CountA(objSheet1.Columns(1))
TotalcolCopy=oXls.Application.WorksheetFunction.Match("Parent Business Process ID", objSheet1.Rows(3), 0)
objSheet1.Range(objSheet1.Cells(4,1),objSheet1.Cells(TotalRows,TotalcolCopy)).Copy(objSheet2.Range("A1"))
objSheet2.Range(objSheet2.Cells(1,2),objSheet2.Cells(TotalRows,TotalcolCopy-1)).Delete(-4159)
'Dim aData : aData=objSheet2.Cells.SpecialCells(12)'xlCellTypeVisible
Dim aData : aData = objSheet2.Range("A1:B"&TotalRows-3)
'MsgBox(LBound(aData, 1)&"And"&UBound(aData, 1))
For nRow = LBound(aData, 1) To UBound(aData, 1)
Set dicP(aData(nRow, 1)) = New cP
'Set dicP(aData(nRow, 2)) = New cP
Next
'objSheet2.Cells.ClearContents'To clear all the previous contenets of the sheet#2
'sKeys=dicP.Keys
'objSheet2.Range("A1").Resize(dicP.Count) = oXls.Application.Transpose(sKeys)
'MsgBox(dicP.Count&":"&UBound(aData, 1)&":"&LBound(aData, 1))
For nRow = LBound(aData, 1) To UBound(aData, 1)
If aData(nRow, 1) = aData(nRow, 2) Then
dicP(aData(nRow, 1)).m_sRel = "Parent"
Else
If dicP.Exists(aData(nRow, 2)) Then
dicP(aData(nRow, 2)).m_dicC.Add aData(nRow, 1), 0 '(aData(nRow, 1)) = 0
End If
End If
Next
objSheet2.Cells.ClearContents'To clear all the previous contenets of the sheet#2
nRow=1
For Each nP In dicP.Keys()
objSheet2.Cells(nRow,1).Value=nP
objSheet2.Cells(nRow,2).Value=dicP(nP).m_sRel
objSheet2.Range("C"&nRow).Resize(1+ UBound(dicP(nP).m_dicC.Keys()) + 1).Value=dicP(nP).m_dicC.Keys()
'Range("C" & nRow).Resize(1, UBound(d.Keys()) + 1).Value = d.Keys()
nRow=nRow+1
Next
I am getting an error as Unknown Run time error at the line objSheet2.Range("C"&nRow).Resize(1+ UBound(dicP(nP).m_dicC.Keys()) + 1).Value=dicP(nP).m_dicC.Keys()
Thanks,
Yes, you assign an array only to one cell. Then only the first value is copied in.
You have to assign the array to a range of the right size. This can be done with Range.Resize.
Then again, Excel treats the array as a 2-dimensional array (a matrix), and if it is only one-dimensional, this will always be the seen as the first row. If you copy this into a vertical range, each cell will have the same first element of your array.
For a vertical range, you have to transpose your array/virtual matrix:
Sub test()
Dim d
Dim nRow As Long
nRow = 3
Set d = CreateObject("Scripting.Dictionary")
d(1) = "A"
d(2) = "B"
d(17) = "C"
d(32) = "F"
' horizontal:
Range("C" & nRow).Resize(1, UBound(d.Keys()) + 1).Value = d.Keys()
' vertical insert needs the data transformed
Range("C" & nRow).Resize(UBound(d.Keys()) + 1).Value = WorksheetFunction.Transpose(d.Keys())
End Sub
For your edit, you may first of all need to correct ("C"&nRow) to ("C" & nRow). The spaces are required.
Another error is Resize(1 + ... + 1), so you add +2, but this should not throw an error.