I have extract something like this from a database:
[{"identifier":{"strategyType":"element1"},"elnSchedules":[{"paymentDate":["element2","element2"]},{"paymentDate":["element2","element2"]}],"composition":{"components":[{"instrument":{"exerciseType":["element3","element3"]}},{"instrument":{"exerciseType":["element3","element3"]}}]},"links":[]}]
I want to build a vba and create a table in excel that has header: strategyType, paymentDate, exerciseType
and elements: element1, element2, element3 under the corresponding header(while each element can only appear once).
so far I have:
For i = 1 To jsonO.Count
'set headings
If i = 1 Then
j = 1
For Each StrKey In jsonO(i).Keys()
activeWS.Cells(i + offset, j) = StrKey
j = j + 1
Next
End If
j = 1
For Each StrKey In jsonO(i).Keys()
If (StrKey <> "links") Then
activeWS.Cells(i + offset + 1, j) = jsonO(i)(StrKey)
j = j + 1
End If
Next
But this only extracts identifier, eLnschedules, and composition and not able to get into specific element.
Is there any way to do it?
Thanks.
-------------------NEW QUESTION----------------------
I used what's posted on the answer and was trying to build a new function under the function posted in the answer(while both of them are called by the main function):
Public Sub GetEndDate()
Dim activeWS As Worksheet
Set activeWS = ThisWorkbook.Worksheets("Data")
Dim jsonStr As String, Json As Object, headers()
'headers = Array("strategyType", "paymentDate", "exerciseType")
jsonStr = [{"optionFeatures":{"Strike Setting":[{"endDate":["2018-10-16"]}]},"links":[]}] '<== read from cell
Set Json = JsonConverter.ParseJson(jsonStr)(1)
activeWS.Cells(1, 13) = Json("optionFeatures")("Strike Setting")("endDate")
End Sub
However it was not able to read from the string, or do I need to reset the lib again?
Thanks.
Using JSONConverter.bas to parse the JSON string read in from a cell as shown below. This assumes you only want one instance of each value.
Note:
After adding in JSONConverter.bas you need to go VBE > Tools > References > Add a reference to Microsoft Scripting Runtime.
Your JSON structure is as follows:
[] indicates a collection, items accessed by index starting from 1. {} indicates a dictionary with items accessed by key.
I traverse the tree using the appropriate syntax to retrieve the first occurrence of each element.
Option Explicit
Public Sub GetInfoFromSheet()
Dim jsonStr As String, Json As Object, headers()
headers = Array("strategyType", "paymentDate", "exerciseType")
jsonStr = [A1] '<== read from cell
Set Json = JsonConverter.ParseJson(jsonStr)(1)
With ThisWorkbook.Worksheets("Sheet1")
.Cells(1, 1).Resize(1, UBound(headers) + 1) = headers
.Cells(2, 1) = Json("identifier")("strategyType")
.Cells(2, 2) = Json("elnSchedules")(1)("paymentDate")(1)
.Cells(2, 3) = Json("composition")("components")(1)("instrument")("exerciseType")(1)
End With
End Sub
Related
I have this code I made from studying multiple posts.
https://www.youtube.com/watch?v=j2RfI75Yfg8
https://www.mrexcel.com/board/threads/storing-unique-values-from-advanced-filter-to-an-array.1048617/
Option Explicit
Sub GetTheUniqueValues()
Dim dict As New Scripting.Dictionary
Dim rng_col_a As Range
Dim col_a_last_row As Long
Dim source_array As Variant
Dim i As Long
Dim j As Long
Dim new_array As Variant
dict.CompareMode = TextCompare
col_a_last_row = ActiveSheet.Range("A1048576").End(xlUp).row
Set rng_col_a = Range(ActiveSheet.Range("A2"), ActiveSheet.Range("A" & col_a_last_row))
source_array = rng_col_a
For i = LBound(source_array) To UBound(source_array)
If source_array(i, 1) <> "" Then dict(source_array(i, 1)) = Empty
Next i
new_array = dict.Keys
For j = LBound(new_array) To UBound(new_array)
ActiveSheet.Range("H" & j + 2).Value = new_array(j)
Next j
End Sub
I would like to understand more about
If source_array(i, 1) <> "" Then dict(source_array(i, 1)) = Empty
I am new to VBA and programming in general so may I now what the "dict(source_array(i, 1)) = Empty" does and why this particular line of code is effective of only putting unique values in the dictionary.
What does it do if the condition is true?
What does it do if the condition is false?
Thank you.
Using dict("a") = Empty tells the dict dictionary that its element with key a has no value (is Empty).
If the dict dictionary doesn't have a key "a", then the code dict("a") = Empty will create it.
That means when cycling through all the values in the source_array, it won't (can't) create duplicates. If key "a" already exists it'll just assign Empty to it again, if it doesn't exist, it'll create it.
This is better than trying to add keys e.g. using
dict.Add "a", Empty
Will only work if key "a" doesn't already exist, but e.g.
dict("a") = Empty
Will either assign Empty to key "a" or create it. It can't error like the first method.
The If source_array(i, 1) <> "" is simply checking that there is a value to create in the first place.
If it's true then it'll try to create the key, if it's false it'll just move to the next i value.
If source_array(i, 1) <> "" Then dict(source_array(i, 1)) = Empty only create a new key and do not allocate any value. If instead of Empty will be 1, the final result will be the same, due to the fact that only the dictionary (unique) keys count...
dict.Keys is an array (independent of the key item values) and only it is used by this code. A shorter version of dropping the dictionary keys would be (without iteration between the array elements):
ActiveSheet.Range("H2").Resize(UBound(new_array) + 1, 1).Value = WorksheetFunction.Transpose(new_array)
A shorter (but interesting, I think) version, for the whole code, would be the next one (it does not need a reference to 'Microsoft Scripting Runtime'):
Sub GetTheUniqueValues()
Dim source_array As Variant, sh As Worksheet, j As Long, col_a_last_row As Long
Set sh = ActiveSheet
col_a_last_row = sh.Range("A" & Rows.count).End(xlUp).row
source_array = sh.Range(sh.Range("A2"), sh.Range("A" & col_a_last_row)).Value
With CreateObject("scripting.dictionary")
For j = 1 To UBound(source_array)
.Item(source_array(j, 1)) = Application.Index(source_array, j, 0)
Next
sh.Range("H2").Resize(.count, UBound(source_array, 2)) = Application.Index(.Items, 0, 0)
End With
End Sub
It would be a bigger challenge to understand it. But still not something very complicated...
I'm trying to check whether the main string contains the entire substring, even if there are interruptions.
For example:
main string = 12ab34cd,
substring = 1234d
should return a positive, since 1234d is entirely contained in my main string, even though there are extra characters.
Since InStr doesn't take wildcards, I wrote my own VBA using the mid function, which works well if there are extra characters at the start/end, but not with extra characters in the middle.
In the above example, the function I wrote
works if the main string is ab1234dc,
but not if it's 12ab34cd.
Is there a way to accomplish what I'm trying to do using VBA?
Note Both of the methods below are case sensitive. To make them case insensitive, you can either use Ucase (or Lcase) to create phrases with the same case, or you can prefix the routine with the Option Compare Text statement.
Although this can be done with regular expressions, here's a method using Mid and Instr
Option Explicit
Function ssFind(findStr, mainStr) As Boolean
Dim I As Long, J As Long
I = 1: J = 1
Do Until I > Len(findStr)
J = InStr(J, mainStr, Mid(findStr, I, 1))
If J = 0 Then
ssFind = False
Exit Function
End If
I = I + 1: J = J + 1
Loop
ssFind = True
End Function
Actually, you can shorten the code further using Like:
Option Explicit
Function ssFind(findStr, mainStr) As Boolean
Dim I As Long
Dim S As String
For I = 1 To Len(findStr)
S = S & "*" & Mid(findStr, I, 1)
Next I
S = S & "*"
ssFind = mainStr Like S
End Function
Assuming you have 3 columns "SUBSTR","MAIN" and "CHECK" and your "Substring" data range is named "SUBSTR"
Sub check_char()
Dim c As Range
For Each c In Range("SUBSTR")
a = 1
test = ""
For i = 1 To Len(c.Offset(0, 1))
If Mid(c.Offset(0, 1), i, 1) = Mid(c, a, 1) Then
test = test & Mid(c.Offset(0, 1), i, 1)
a = a + 1
End If
Next i
If test = c Then
c.Offset(0, 2) = "MATCH"
Else
c.Offset(0, 2) = "NO MATCH"
End If
Next
End Sub
I have a function meant to return an array which is created out of a single-column list of data. I have been using this function's return value essentially as a pseudo-global variable (LINENAMES_ARRAY) which I pass to many functions. Those functions than do checks on it such as If Len(Join(LINENAMES_ARRAY)) = 0 Then or go through items with For Each statements. Here is the code:
Function LINENAMES_ARRAY() As Variant
'returns an array of all items in the main sheet linenames column
LINENAMES_ARRAY = Application.Transpose(MAIN.Range( _
MAIN.Cells(MAIN_HEAD_COUNT + 1, MAIN_LINENAMES_COLUMN), _
MAIN.Cells(LINENAMES_COUNT + 1, MAIN_LINENAMES_COLUMN)))
End Function
I recently stumbled on one of those you-don't-see-it-till-you-see-it problems while using this workbook for a new project, where if the array happens to be only 1 element, everything fails. Apparently in that case, this returns a single value so Join() will fail For Each __ in LINENAMES_ARRAY will too. Why won't it treat this as a 1x1 array rather than a free value? I have started to mitigate the problem by rewriting functions where this is called, to check whether it is an array, then do some other procedure. Things like:
For j = 1 To LINENAMES_COUNT
LINES_BOX.AddItem lineNames(j)
Next j
is changed to:
If Not IsArray(LINENAMES_ARRAY) Then
myListBox.AddItem CStr(LINENAMES_ARRAY)
Else
For j = 1 To LINENAMES_COUNT
LINES_BOX.AddItem LINENAMES_ARRAY(j)
Next j
End If
However this becomes messy and is adding many extra checks to my code that I would prefer to handle in the LINENAMES_ARRAY function. Is there a way to return a 1x1 array? Or any other workaround?
An array can have a single element if you create it as a single element array and populate it in an array manner.
Option Explicit
Dim MAIN_HEAD_COUNT As Long
Dim LINENAMES_COUNT As Long
Dim MAIN_LINENAMES_COLUMN As Long
Dim MAIN As Worksheet
Sub stuff()
Dim arr As Variant
Set MAIN = Worksheets("Sheet1")
MAIN_LINENAMES_COLUMN = 2
MAIN_HEAD_COUNT = 2
LINENAMES_COUNT = 2
arr = LINENAMES_ARRAY()
Debug.Print IsArray(arr)
Debug.Print LBound(arr) & ":" & UBound(arr)
End Sub
Function LINENAMES_ARRAY() As Variant
Dim a As Long, tmp() As Variant
ReDim tmp(0 To LINENAMES_COUNT - MAIN_HEAD_COUNT)
For a = 0 To LINENAMES_COUNT - MAIN_HEAD_COUNT
tmp(a) = MAIN.Range(MAIN.Cells(MAIN_HEAD_COUNT + 1, MAIN_LINENAMES_COLUMN), _
MAIN.Cells(LINENAMES_COUNT + 1, MAIN_LINENAMES_COLUMN)).Cells(a).Value2
Next a
'returns an array of all items in the main sheet linenames column
LINENAMES_ARRAY = tmp
End Function
Results from the VBE's Immediate window:
True
0:0
I need to reformat a XML file to .CSV.
I already opened the XML in Excel and did a little formating but now I really need to write a macro to get the data into shape. I already started bu I really have issues with the loop logic.
the List has a couple thousand Articles with a variable amount of subarticles.
each subarticle as a the same amount of properties but not every article has the same properties.
https://picload.org/image/ipialic/now.jpg
https://picload.org/image/ipialip/then.jpg
My Code up till now looks like this:
Option Explicit
Dim rowCount As Long, articleCount As Long, propertyCount As Integer, name As String
Sub Sortfunction()
rowCount = 1
articleCount = 0
propertyCount = 0
Do While Sheets("Test").Cells(rowCount, 1).Value <> "end"
If Cells(rowCount, 1).Value = "Reference" Then
rowCount = rowCount + 1
Do While Cells(rowCount, 3).Value = ""
If Cells(rowCount, 3).Value = "4" Then
End If
articleCount = articleCount + 1
Loop
articleCount = articleCount + 1
End If
rowCount = rowCount + 1
Loop
Sheets("result").Cells(1, 1).Value = rowCount
Sheets("result").Cells(2, 1).Value = articleCount
End Sub
At the end of the document i wrote the "end" to have a hook to stop the loop.
Can anyone provide some help? I'm really not the best programmer :-/
I'd really appreciate any help I can get :-)
here he's a translation into algorithm and some tips on functions
update: it was more tricky than I thought... I had to rewrite the code.
The main problem is "how to decide when change column".
I choose this solution "Each product in reference must have the same amount of properties".
If it's not the case, please indicate "how you decide when you have to create a new Column" (you can explain it in plain words)
Here the code rewrited. I tried it on your exemple, it work
Public Sub test()
' Set the range to navigate in your first sheet
Dim cell As Range: Set cell = Sheets("Feuil1").Range("A1")
' set the range to navigate in your result sheet
Dim res As Range: Set res = Nothing
' pos will be used to know the position of a product
Dim lastProperties As Range, posProperties As Range
' While the cell value is not "end"
Do While cell <> "end"
' if the cell is a reference
If cell = "Reference" Then
' Set the range of res
If res Is Nothing Then
Set res = Sheets("Feuil2").Range("A1")
Else
Set res = Sheets("Feuil2").Range("A" & lastProperties.offset(2).Row)
End If
' I set Offset(2) so you will have an empty line between 2 references
' Set the text of the new reference in the result
res = cell.offset(, 1) ' The reference is the cell 1 offset the right of the cell "Reference"
' WARNING : here no writing of titles anymore. It'll be done in the "Else".
' Here you just write "new reference" and reinit var
Else
' Here we have a property
' If the property alreay exist, consider it a new product in the reference
' When we are on a new property, the column of the product if the next to the right
If GetProperties(cell.offset(, 3), res, posProperties) Then
Set lastProperties = posProperties
End If
posProperties = cell.offset(, 4)
End If
' BIG FORGET: you have to get the next cell
Set cell = cell.offset(1)
Loop
End Sub
And the function to search / create your properties
Private Function GetProperties(ByVal propValues As String, ByVal start As Range, ByRef position As Range) As Boolean
Set position = start.offset(1)
' Is the cell below the properties ? Return the row below
' Search for the first "empty row" on the line
If position = propValues Then
Do
Set position = position.offset(, 1)
Loop While Trim(position) <> ""
' Indicate it's an existing value
GetProperties = True
Exit Function
End If
' Is the range empty ?
If Trim(position) = "" Then
' Create the new properties
position = propValues
Set position = position.offset(, 1)
GetProperties = False
Exit Function
End If
' Search the properties in the row below
GetProperties = GetProperties(propValues, position, position)
End Function
It should do the work. If you have any question on understanding some part, don't hesitate
if you don't know about Offset, some reading : https://msdn.microsoft.com/en-us/library/office/ff840060.aspx
I need to format a large set of data across multiple columns.
I have data in sets of 2 columns that need to be formatted into one set of 2 columns, in addition to headers that need to be in cells to the left of the data.
So I need to covert data that is in two columns to:
header1 header2 data1 data2
So the header needs to be copied and pasted all the way down the columns and the multiple columns and headers need to be appended.
This needs to loop across a whole spreadsheet.
Below is my attempt
colA = 5
colB = 3
colC = 2
rowA = 3
rowB = 3
cellA = "C1"
Worksheets("sheet3").Activate
lastA = Cells(Rows.Count, colB).End(xlUp).Row
For x = rowA To lastA
Worksheets("sheet3").Activate
Data = Cells(x, colA)
Worksheets("sheet3").Activate
Cells(rowB, colB) = Data
rowB = rowB + 1
Next x
Do Until colC = 0
Selection.Cut
Cells(1, colB).Select
ActiveSheet.Paste
Range("D1").Select
Selection.AutoFill Destination:=Cells(3, colC)
colC = colB - 1
Different approach.
Read the source data into an array.
Set up a Class consisting of the data for each resultant row
Iterate through the source array, two columns at a time, to construct each row.
Store the RowData into a collection.
When done, transfer the collection into a "results" array.
Write the results array to a Range (I chose to do do this on a different worksheet). Edit the source and destination ranges as required.
First Insert a Class Module; Rename it RowData, and paste the code below:
Option Explicit
Private pHeaderOdd As String
Private pHeaderEven As String
Private pDataOdd As String
Private pDataEven As String
Public Property Get HeaderOdd() As String
HeaderOdd = pHeaderOdd
End Property
Public Property Let HeaderOdd(Value As String)
pHeaderOdd = Value
End Property
Public Property Get HeaderEven() As String
HeaderEven = pHeaderEven
End Property
Public Property Let HeaderEven(Value As String)
pHeaderEven = Value
End Property
Public Property Get DataOdd() As String
DataOdd = pDataOdd
End Property
Public Property Let DataOdd(Value As String)
pDataOdd = Value
End Property
Public Property Get DataEven() As String
DataEven = pDataEven
End Property
Public Property Let DataEven(Value As String)
pDataEven = Value
End Property
Then, in a regular module, paste the following code:
Sub ReFormat()
Dim V As Variant, vRes() As Variant
Dim cRD As RowData
Dim colRD As Collection
Dim I As Long, J As Long
'Get entire source data into array
'May need a different selection method
' depending on your "real" data arrangement
V = Worksheets("Sheet4").Range("a1").CurrentRegion
'initialize collection
Set colRD = New Collection
'get data in pairs and add to collection
For I = 1 To UBound(V, 2) Step 2 'columns
For J = 2 To UBound(V, 1) 'rows
Set cRD = New RowData
cRD.HeaderOdd = V(1, I)
cRD.HeaderEven = V(1, I + 1)
cRD.DataOdd = V(J, I)
cRD.DataEven = V(J, I + 1)
colRD.Add cRD
Next J
Next I
'Put collection into "results" array for writing to the results range
ReDim vRes(1 To colRD.Count, 1 To 4)
For I = 1 To colRD.Count
vRes(I, 1) = colRD(I).HeaderOdd
vRes(I, 2) = colRD(I).HeaderEven
vRes(I, 3) = colRD(I).DataOdd
vRes(I, 4) = colRD(I).DataEven
Next I
Worksheets("Sheet2").Cells.Clear
Worksheets("Sheet2").Range("A1").Resize(UBound(vRes, 1), UBound(vRes, 2)) = vRes
End Sub
Ensure your worksheet and range references are correct, and run the macro.