VBA: Creating substrings out of JSON and reformatting into columns

Question

I have information from a Facebook FQL Query in the form of JSON and pasted it into Excel. Here's a part of the result:

"data": [

{
  "name": "Hilton Head Island - TravelTell", 
  "location": {
    "street": "7 Office Way, Suite 215", 
    "city": "Hilton Head Island", 
    "state": "SC"
  }, 
  "fan_count": 143234, 
  "talking_about_count": 18234, 
  "were_here_count": 4196
}, 
{
  "name": "Hilton Hawaiian Village Waikiki Beach Resort", 
  "location": {
    "street": "2005 Kalia Road", 
    "city": "Honolulu", 
    "state": "HI"
  }, 
  "fan_count": 34072, 
  "talking_about_count": 4877, 
  "were_here_count": 229999
}, 
{
  "name": "Hilton New York", 
  "location": {
    "street": "1335 Avenue of the Americas", 
    "city": "New York", 
    "state": "NY"
  }, 
  "fan_count": 12885, 
  "talking_about_count": 969, 
  "were_here_count": 72206
},

I'm trying to use substrings to parse the data and then create columns on another worksheet using "name, street, city, state, fan_count, etc." as the column headers. I'm trying out code to do this for just "name:" right now but there's an error when it hits the line with documentText = myRange.Text . I can't figure out what the error is.

Another problem is that the strings contain quotations. For example, I want the SecondTerm to be ", but I get errors when I try to have it equal "","

Sub Substring_Test()

Dim nameFirstTerm As String
Dim nameSecondTerm As String
Dim myRange As Range
Dim documentText As String

Dim startPos As Long 'Stores the starting position of firstTerm
Dim stopPos As Long 'Stores the starting position of secondTerm based on first term's location
Dim nextPosition As Long 'The next position to search for the firstTerm

nextPosition = 1

'First and Second terms as defined by your example.  Obviously, this will have to be more dynamic
'if you want to parse more than justpatientFirstname.
firstTerm = "name"": """
secondTerm = ""","""

'Get all the document text and store it in a variable.
Set myRange = Sheets("Sheet1").UsedRange
'Maximum limit of a string is 2 billion characters.
'So, hopefully your document is not bigger than that.  However, expect declining performance based on how big doucment is
documentText = myRange.Text

'Loop documentText till you can't find any more matching "terms"
Do Until nextPosition = 0
    startPos = InStr(nextPosition, documentText, firstTerm, vbTextCompare)
    stopPos = InStr(startPos, documentText, secondTerm, vbTextCompare)
    Debug.Print Mid$(documentText, startPos + Len(firstTerm), stopPos - startPos - Len(secondTerm))
    nextPosition = InStr(stopPos, documentText, firstTerm, vbTextCompare)
Loop

Sheets("Sheet2").Range("A1").Value = documentText

End Sub

http://stackoverflow.com/questions/14822672/parsing-a-json-object-array-in-excel-vba/14823059#14823059 — Tim Williams, Feb 25 '13 at 18:17
http://stackoverflow.com/questions/4130849/convert-json-format-to-csv-format-for-ms-excel It sounds like this answer will free you from having to hand-parse the json. — Dan Metheus, Feb 25 '13 at 18:24

Tim Williams · Answer 1 · 2013-02-26T22:59:19.883

Sub Tester()

    Dim json As String
    Dim sc As Object
    Dim o, loc, x, num

    Set sc = CreateObject("scriptcontrol")
    sc.Language = "JScript"

    json = ActiveSheet.Range("a1").Value
    'Debug.Print json

    sc.Eval "var obj=(" & json & ")" 'evaluate the json response

    'Add some accessor functions...
    '  get count of records returned
    sc.AddCode "function getCount(){return obj.data.length;}"

    '  return a specific record (with some properties renamed)
    sc.AddCode "function getItem(i){var o=obj.data[i];" & vbLf & _
                      "return {nm:o.name,loc:o.location," & vbLf & _
                      "f:o.fan_count,ta:o.talking_about_count," & vbLf & _
                      "wh:o.were_here_count};}"

    num = sc.Run("getCount")
    Debug.Print "#Items", num

    For x = 0 To num - 1
        Debug.Print ""
        Set o = sc.Run("getItem", x)
        Debug.Print "Name", o.nm
        Debug.Print "Street", o.loc.street
        Debug.Print "City", o.loc.city
        Debug.Print "Street", o.loc.street
        Debug.Print "Fans", o.f
        Debug.Print "talking_about", o.ta
        Debug.Print "were_here", o.wh
    Next x

End Sub

Note: the javascript getItem function dosn't return a record directly, but wraps the data so that some of the JSON-drived property names are altered (specifically "name" and "location"). VBA seems to have a problem dealing with accessing properties on objects passed from javascript if the property name resembles a "regular" property like Name (or Location).

Thanks for the help!I'd give you useful points if I had enough reputation points. — Momo, Mar 01 '13 at 16:52

score 1 · Answer 2 · answered Feb 25 '13 at 18:15

1

I have no clue about the 1st part (not familiar with JSON at all), but regarding the 2nd one - try the following lines:

firstTerm = Chr(34) & "name: " & Chr(34)
secondTerm = Chr(34) & ","

Or simply - use Chr(34) for every double quote you want.

answered Feb 25 '13 at 18:15

Peter L.

7,276
5
34
53

score 1 · Accepted Answer · answered Feb 25 '13 at 19:14

This should work although you may need to change some of the sheet names

Sub Test()
    Dim vData() As Variant
    Dim vHeaders As Variant
    Dim vCell As Variant
    Dim i As Long

    vHeaders = Array("Name", "Street", "City", "State", "Fan Count", "Talking About Count", "Were Here Count")

    i = 1
    Do While i <= ActiveSheet.UsedRange.Rows.Count
        If InStr(Cells(i, 1).Text, "{") Or _
           InStr(Cells(i, 1).Text, "}") Or _
           Cells(i, 1).Text = """data"": [" Or _
           Cells(i, 1).Text = "" Then
            Rows(i).Delete
        Else
            Cells(i, 1).Value = Replace(Cells(i, 1).Text, """", "")
            Cells(i, 1).Value = Replace(Cells(i, 1).Text, ",", "")
            Cells(i, 1).Value = WorksheetFunction.Trim(Cells(i, 1).Text)
            i = i + 1
        End If
    Loop

    i = 0
    For Each vCell In Range(Cells(1, 1), Cells(ActiveSheet.UsedRange.Rows.Count, 1))
        If InStr(vCell.Text, "name:") Then
            i = i + 1
            ReDim Preserve vData(1 To 7, 1 To i)
        End If

        If InStr(vCell.Text, "name") Then
            vData(1, i) = Right(vCell.Text, Len(vCell.Text) - InStr(1, vCell.Text, ":"))
        End If

        If InStr(vCell.Text, "street") Then
            vData(2, i) = Right(vCell.Text, Len(vCell.Text) - InStr(1, vCell.Text, ":"))

        End If

        If InStr(vCell.Text, "city") Then
            vData(3, i) = Right(vCell.Text, Len(vCell.Text) - InStr(1, vCell.Text, ":"))

        End If

        If InStr(vCell.Text, "state") Then
            vData(4, i) = Right(vCell.Text, Len(vCell.Text) - InStr(1, vCell.Text, ":"))
        End If

        If InStr(vCell.Text, "fan_count") Then
            vData(5, i) = Right(vCell.Text, Len(vCell.Text) - InStr(1, vCell.Text, ":"))

        End If

        If InStr(vCell.Text, "talking_about_count") Then
            vData(6, i) = Right(vCell.Text, Len(vCell.Text) - InStr(1, vCell.Text, ":"))

        End If

        If InStr(vCell.Text, "were_here_count") Then
            vData(7, i) = Right(vCell.Text, Len(vCell.Text) - InStr(1, vCell.Text, ":"))
        End If
    Next

    'Cells.Delete
    Sheets("Sheet2").Select
    Range(Cells(1, 1), Cells(UBound(vData, 2), UBound(vData))).Value = WorksheetFunction.Transpose(vData)
    Rows(1).EntireRow.Insert
    Range(Cells(1, 1), Cells(1, UBound(vHeaders) + 1)).Value = vHeaders

End Sub

VBA: Creating substrings out of JSON and reformatting into columns

3 Answers3

Linked