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
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
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).
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.
