• Hi All

    Please note that at the Chandoo.org Forums there is Zero Tolerance to Spam

    Post Spam and you Will Be Deleted as a User

    Hui...

  • When starting a new post, to receive a quicker and more targeted answer, Please include a sample file in the initial post.

List all values from giant string

E

exc4libur

Member
Hi guys,

I am trying to list all the values inside "{ .... }" from the string below.
http://casadopaodequeijo.com.br/resource/scripts/custom-map-default.js.

I have attached a sample workbook with the example below:

Link http://casadopaodequeijo.com.br/resource/scripts/custom-map-default.js
Value 1 {id:"0",name:"SHOPPING RIO MAR",address:"Av. Delmiro Gouveia, S Nº Loja 132 Piso I",uf:"SE",city:"Aracajú",telephone:"",neightbordhood:"",latitude:-10.9091511,longitude:-37.0744542}
Value 2 {id:"1",name:"SHOPPING BALNEÁRIO CAMBORIU",address:"Av. Santa Catarina, 01 Loja 41",uf:"SC",city:"Balneário Camboriú",telephone:"",neightbordhood:"",latitude:-27.019084,longitude:-48.6522345}
Value N etc,,


Any help would be much appreciated
Thank you :)
 

Attachments

  • Workbook1.xlsx
    28.7 KB · Views: 5
As my link thread is unachieved, try this Demo procedure :
Code: 
Dim JSc As Object

Function TextRequest$(URL$)
    With CreateObject("MSXML2.XMLHttp")
        .Open "GET", URL, False
        .setRequestHeader "DNT", "1"
         On Error Resume Next
        .send
         If .Status = 200 Then TextRequest = .responseText Else Beep
    End With
End Function

Function jsonEval(jsonTXT$) As Object
 If JSc Is Nothing Then
Set JSc = CreateObject("ScriptControl")
    JSc.Language = "JScript"
    JSc.AddCode "function getKeys(jsonObj) { var keys = []; for (var i in jsonObj) { keys.push(i); } return keys; }"
End If
      Set jsonEval = JSc.Eval("(" & jsonTXT & ")")
End Function

Function jsonAllColumns(TXT$)
          Dim oKeys As Object, oRoot As Object, SP$()
          Set oRoot = jsonEval(TXT)
          Set oKeys = JSc.Run("getKeys", oRoot)
If CallByName(oKeys, 0, VbGet) = "0" Then
    L& = CallByName(oKeys, "length", VbGet) + 1
    SP = Split(JSc.Run("getKeys", CallByName(oRoot, 0, VbGet)), ",")
    D& = UBound(SP) + 1
    ReDim VT(1 To L, 1 To D)
    For C& = 1 To D:  VT(1, C) = SP(C - 1):  Next
        On Error Resume Next
    For R& = 2 To L
           Set oKeys = CallByName(oRoot, R - 2, VbGet)
        For C = 1 To D
            VT(R, C) = CallByName(oKeys, VT(1, C), VbGet)
        Next
    Next
         jsonAllColumns = VT
End If
    Set JSc = Nothing:  Set oKeys = Nothing:  Set oRoot = Nothing
End Function

Sub Demo()
    T$ = TextRequest("http://casadopaodequeijo.com.br/resource/scripts/custom-map-default.js")
    If T = "" Then Exit Sub
    VA = jsonAllColumns("[" & Split(Split(T, "[")(1), "]")(0) & "]")
    If Not IsArray(VA) Then Beep: Exit Sub
         ActiveSheet.UsedRange.Clear
    With Cells(1).Resize(UBound(VA), UBound(VA, 2))
        .Value = VA
        .Columns.AutoFit
    End With
End Sub
Do you like it ? So thanks to click on bottom right Like !
​
 
Completely different method.
Code: 
Sub test()
    Dim txt As String, i As Long
    With CreateObject("MSXML2.XMLHttp")
        .Open "GET", "http://casadopaodequeijo.com.br/resource/scripts/custom-map-default.js", False
         On Error Resume Next
        .Send
         If .Status = 200 Then txt = .responseText
    End With
    If txt = "" Then Exit Sub
    With CreateObject("VBScript.RegExp")
        .Global = "true"
        .Pattern = "\[\{[^\]]+\}\]"
        txt = .Execute(txt)(0)
        .Pattern = "\{(.*?)\}"
        If .test(txt) Then
            For i = 0 To .Execute(txt).Count - 1
                Cells(i + 1, 1) = .Execute(txt)(i).submatches(0)
            Next
        End If
    End With
End Sub
 

Yes, different method as well for the result :
on my side with jindon's code, id "174" is missing !
​
 
exc4libur,
This is not how you asked originally but
If you want it to be separated then try this
Code: 
Sub test()
    Dim txt As String, mtch As Object, i As Long, m As Object, dic As Object, a()
    Set dic = CreateObject("Scripting.Dictionary")
    With CreateObject("MSXML2.XMLHttp")
        .Open "GET", "http://casadopaodequeijo.com.br/resource/scripts/custom-map-default.js", False
         On Error Resume Next
        .send
         If .Status = 200 Then txt = .responseText
    End With
    If txt = "" Then Exit Sub
    On Error GoTo 0
    With CreateObject("VBScript.RegExp")
        .Global = "true"
        .Pattern = "\[\{[^\]]+\}\]"
        txt = .Execute(txt)(0)
        .Pattern = "\{.*?\}"
        Set mtch = .Execute(txt)
        ReDim a(1 To mtch.Count + 1, 1 To 1)
        .Pattern = "([^{"",:]*?):(""([^""]*)""|([+-]?\d+\.\d+))"
        For i = 0 To mtch.Count - 1
            For Each m In .Execute(mtch(i))
                If Not dic.exists(m.submatches(0)) Then
                    dic(m.submatches(0)) = dic.Count + 1
                    If UBound(a, 2) < dic.Count Then
                        ReDim Preserve a(1 To UBound(a, 1), 1 To dic.Count + 1)
                    End If
                    a(1, dic.Count) = m.submatches(0)
                End If
                a(i + 2, dic(m.submatches(0))) = _
                IIf(m.submatches(2) <> "", m.submatches(2), m.submatches(3))
            Next
        Next
    End With
    Cells(1).Resize(UBound(a, 1), UBound(a, 2)).Value = a
End Sub
 
Marc L said:

Which ? I see nothing additional from webbrowser window …
​
Click to expand...
Hi Marc ,

Copy any one line of data from the starting { till the ending } into Excel ; do it for any line which is displayed , and do it for the 2 lines which are missing ( 174 and 349 ) ; you will see the difference.

Narayan
 
NARAYANK991 said:
Hi ,

Basically these two items of data have additional characters.

Narayan
Click to expand...
I didn't know you guys are talking about my codes...
See
Code: 
Sub test()
    Dim txt As String, mtch As Object, i As Long, m As Object, dic As Object, a()
    Set dic = CreateObject("Scripting.Dictionary")
    With CreateObject("MSXML2.XMLHttp")
        .Open "GET", "http://casadopaodequeijo.com.br/resource/scripts/custom-map-default.js", False
         On Error Resume Next
        .send
         If .Status = 200 Then txt = .responseText
    End With
    If txt = "" Then Exit Sub
    On Error GoTo 0
    With CreateObject("VBScript.RegExp")
        .Global = "true"
        .Pattern = "\[\{[^\]]+\}\]"
        txt = .Execute(txt)(0)
        .Pattern = "\{[^}]*?\}"
        Set mtch = .Execute(txt)
        ReDim a(1 To mtch.Count + 1, 1 To 1)
        .Pattern = "([^{"",:\r\n]*?):(""([^""]*)""|([+-]?\d+\.\d+))"
        For i = 0 To mtch.Count - 1
            For Each m In .Execute(mtch(i))
                If Not dic.exists(m.submatches(0)) Then
                    dic(m.submatches(0)) = dic.Count + 1
                    If UBound(a, 2) < dic.Count Then
                        ReDim Preserve a(1 To UBound(a, 1), 1 To dic.Count + 1)
                    End If
                    a(1, dic.Count) = m.submatches(0)
                End If
                a(i + 2, dic(m.submatches(0))) = _
                IIf(m.submatches(2) <> "", m.submatches(2), m.submatches(3))
            Next
        Next
    End With
    Cells(1).Resize(UBound(a, 1), UBound(a, 2)).Value = a
End Sub
 
jindon,

next issue with your third code is missing latitude of ids 67 to 69 …

I just see my code has same issue with latitude or longitude
with many others ids ! Edit : issue fixed directly in post #5 …
​
 
3rd pattern
Code: 
       Set mtch = .Execute(txt)
       ReDim a(1 To mtch.Count + 1, 1 To 1)
        .Pattern = "([^{"",:\r\n]*?):(""([^""]*)""|([+-]?\d+\.\d+))" '<- this line
Should be
Code: 
        Set mtch = .Execute(TXT)
        ReDim a(1 To mtch.Count + 1, 1 To 1)
        .Pattern = "([^{"",:\r\n]*?):(""([^""]*)""|([+-]?\d*\.\d+))" '<- this line

BTW, your code leaves lat/long blank when telephone appears, line 156,158 for example.
 
Marc L said:
I just see my code has same issue with latitude or longitude
with many others ids !
Click to expand...
Issue fixed directly in post #5 …
The source wasn't the telephone but a loop all in a single codeline
where an error can occurs using On Error Resume Next
- when there is a missing header like neightbordhood in a record -
fine now with a multi lines loop (jsonAllColumns function).

jindon, with your new third pattern, you rock !
​
 
You must log in or register to reply here.
Back
Top