VBA:使用JSON创建子字符串并将其重新格式化为列 [英] VBA: Creating substrings out of JSON and reformatting into columns

问题描述

我从JSON形式的Facebook FQL查询中获取信息，并将其粘贴到Excel中.这是结果的一部分:

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
},

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

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.

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

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

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

结束子

推荐答案

这应该有效，尽管您可能需要更改某些工作表名称

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:使用JSON创建子字符串并将其重新格式化为列的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！