Question

我以JSON的形式从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
},

我正在尝试使用子字符串来解析数据，然后使用“name，street，city，state，fan_count等”在另一个工作表上创建列。作为列标题。我正在尝试使用“name：”来执行此代码，但是当它遇到documentText = myRange.Text的行时会出现错误。我无法弄清楚错误是什么。

另一个问题是字符串包含引号。例如，我希望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

End Sub

Answer 1

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

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

Answer 2

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

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

或者简单地 - 对所需的每个双引号使用Chr(34)。

Answer 3

虽然您可能需要更改某些工作表名称

，但这应该有效

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：使用JSON创建子字符串并重新格式化为列

3 个答案: