0

我有来自 Facebook FQL 查询的 JSON 格式的信息并将其粘贴到 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
},

我正在尝试使用子字符串来解析数据，然后使用“名称、街道、城市、州、fan_count 等”在另一个工作表上创建列。作为列标题。我现在正在尝试仅针对“名称：”执行此操作的代码，但是当它到达 documentText = myRange.Text 的行时出现错误。我无法弄清楚错误是什么。

另一个问题是字符串包含引号。例如，我希望 SecondTerm 为“，但是当我尝试使其等于“”时出现错误，

子 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

结束子

4

3 回答 3

2 
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

注意： javascriptgetItem函数不直接返回记录，而是包装数据，以便更改一些 JSON 驱动的属性名称（特别是“名称”和“位置”）。Name如果属性名称类似于（或Location）之类的“常规”属性，VBA 似乎在处理访问从 javascript 传递的对象的属性时会遇到问题。

于 2013-02-25T20:15:57.360 回答
1

这应该可以工作，尽管您可能需要更改一些工作表名称

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
于 2013-02-25T19:14:58.623 回答
1

我对第一部分一无所知（根本不熟悉 JSON），但关于第二部分 - 请尝试以下几行：

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

或者简单地说 -Chr(34)用于您想要的每个双引号。

于 2013-02-25T18:15:45.960 回答