VBA：从JSON中创build子string并重新格式化为列
我从JSON的forms从Facebook FQL查询中获得信息并将其粘贴到Excel中。 以下是结果的一部分：
“数据”：[
{ "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 },
我试图使用子string来parsing数据，然后使用“名称，街道，城市，州，fan_count等”在另一个工作表上创build列。 作为列标题。 我正在尝试代码，只是为了“名称：”现在，但它有一个错误，当它与documentText = myRange.Text行。 我无法弄清楚错误是什么。
另一个问题是string包含引号。 例如，我希望SecondTerm是“，但是当我尝试让它相等时，我会得到错误”，“
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结束小组
这应该工作，虽然你可能需要改变一些表名
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", of Debug.Print "talking_about", o.ta Debug.Print "were_here", o.wh Next x End Sub
注意： javascript getItem函数不会直接返回logging，而是包装数据，以便更改一些JSON驱动的属性名称（特别是“名称”和“位置”）。 如果属性名称类似于“常规”属性，如Name （或Location ），VBA似乎有一个问题处理访问从JavaScript传递的对象的属性。
我不知道第一部分（不熟悉JSON），但关于第二部分 – 尝试以下几行：
firstTerm = Chr(34) & "name: " & Chr(34) secondTerm = Chr(34) & ","
或者干脆 – 使用Chr(34)来获得每一个你想要的双引号。