VBA: Создание подстрок из JSON и переформатирования в колонки

Я имею информацию от Вопроса FQL Facebook в форме JSON и приклеил его в Excel. Вот часть результата:

"данные": [

  {
  "имя": "Остров Хилтон-Хеда - TravelTell", 
  "местоположение": {
    "улица": "7 офисов путь, номер люкс 215", 
    "город": "Остров Хилтон-Хеда", 
    "государство": "SC"
  }, 
  "fan_count": 143234, 
  "talking_about_count": 18234, 
  "were_here_count": 4196
}, 
{
  "имя": "Гаваец Хилтон Деревня Вайкики-Бич Резорт", 
  "местоположение": {
    "улица": "Кэлия-Роуд 2005", 
    "город": "Гонолулу", 
    "государство": "ПРИВЕТ"
  }, 
  "fan_count": 34072, 
  "talking_about_count": 4877, 
  "were_here_count": 229999
}, 
{
  "имя": "Хилтон Нью-Йорк", 
  "местоположение": {
    "улица": "Проспект 1335 Америк", 
    "город": "Нью-Йорк", 
    "государство": "Нью-Йорк"
  }, 
  "fan_count": 12885, 
  "talking_about_count": 969, 
  "were_here_count": 72206
},
 

Я пытаюсь использовать подстроки, чтобы разобрать данные и затем создать колонки на другом рабочем листе, используя "имя, улицу, город, государство, fan_count, и т.д." как заголовки столбцов. Я испытываю код, чтобы сделать это для просто "имени": прямо сейчас, но есть ошибка, когда она поражает линию documentText = myRange. Текст. Я не могу выяснить, какова ошибка.

Другая проблема состоит в том, что последовательности содержат цитаты. Например, я хочу, чтобы SecondTerm был", но я получаю ошибки, когда я пытаюсь иметь его равный""",

Sub Substring_Test ()

  Затемняют nameFirstTerm Как Последовательность
Затемните nameSecondTerm Как Последовательность
Затемните myRange Как Диапазон
Затемните documentText Как Последовательность

Затемните startPos, Поскольку Долго 'Хранит стартовую позицию firstTerm
Затемните stopPos, Поскольку Долго 'Хранит стартовую позицию secondTerm на основе местоположения первого срока
Затемните nextPosition Как Долго 'Следующее положение, чтобы искать firstTerm

nextPosition = 1

'Первые и Вторые сроки, как определено вашим примером. Очевидно, это должно будет быть более динамично
'если вы хотите разобрать больше, чем justpatientFirstname.
firstTerm = "имя"": """
secondTerm =""" """,

'Получите весь текст документа и сохраните его в переменной.
Набор myRange = Листы ("Sheet1").UsedRange
'Максимальный предел последовательности - 2 миллиарда знаков.
'Так, надо надеяться ваш документ не больше, чем это. Однако ожидайте уменьшать работу на основе того, как большой doucment
documentText = myRange. Текст

'Петля documentText, пока вы не можете найти больше соответствие "условиям"
Сделайте До nextPosition = 0
    startPos = InStr (nextPosition, documentText, firstTerm, vbTextCompare)
    stopPos = InStr (startPos, documentText, secondTerm, vbTextCompare)
    Отладка. Mid$ печати (documentText, startPos + Лен (firstTerm), stopPos - startPos - Лен (secondTerm))
    nextPosition = InStr (stopPos, documentText, firstTerm, vbTextCompare)
Петля

Листы ("Sheet2").Range ("A1").Value = documentText
 

Конец Sub

0
nl ja de
stackoverflow.com/questions/14822672/…
добавлено автор Tim Williams, источник
stackoverflow.com/questions/4130849/… Это походит на этот ответ, освободит вас от необходимости до ручного разбора json.
добавлено автор Dan Metheus, источник

3 ответы

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

2
добавлено
Спасибо за помощь! I' d дают вам полезные пункты, если у меня было достаточно пунктов репутации.
добавлено автор Momo, источник

Это должно работать, хотя вы, возможно, должны поменять некоторые листовые имена

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
1
добавлено
Спасибо!! Это работало отлично.
добавлено автор Momo, источник

У меня нет подсказки о 1-й части (не знакомый с JSON вообще), но относительно 2-го - пробуют следующие линии:

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

Или просто - использование Chr (34) для каждой двойной кавычки вы хотите.

1
добавлено
JavaScript Jobs — чат
JavaScript Jobs — чат
8 336 участник(ов)

JavaScript Jobs — чат для поиска работы и людей Правила оформления: https://teletype.in/@telegram-ru/r1WQe5F1m См. также: @mobile_jobs, @devops_jobs, @nodejs_jobs, @react_js, @angular_ru, @js_ru

JavaScript.ru
JavaScript.ru
7 932 участник(ов)

Сообщество сайта JavaScript.ru в Slack.

pro.js
pro.js
4 675 участник(ов)

Про JavaScript и NodeJS Invite: https://t.me/joinchat/Be4rsT5Rsgq30DHutjxXgA Правила: http://telegra.ph/ru-chat-rules-06-19 Вакансии только с ЗП, не чаще раза в неделю.

JavaScript — русскоговорящее сообщество
JavaScript — русскоговорящее сообщество
3 269 участник(ов)

Рекомендуем сразу отключить уведомления Правила: https://rudevs.network/ByaMH6un7 См. также: @js_noobs_ru, @nodejs_ru, @typescript_ru, @react_js, @electron_ru Вакансии и поиск работы: @javascript_jobs

JavaScript Noobs — сообщество новичков
JavaScript Noobs — сообщество новичков
2 484 участник(ов)

Чат для новичков

javascript_ru
javascript_ru
915 участник(ов)

Сообщество любителей самого популярного языка программирования в мире. Чат основан в 2009 году. Логи: https://goo.gl/9EOeM7 Поддержка бота: @chat_linker (ссылка на репу внутри) Вам будут интересны @frontend_ru и @css_ru

jsChat
jsChat
603 участник(ов)

Чат посвященный программированию на языке javaScript Перед отправкой ссылки на Ваш контент посоветуйтесь с админом Все ссылки удаляются ботом автоматически

JavaScript for Zombies Chat
JavaScript for Zombies Chat
492 участник(ов)

Чат про JavaScript для настоящих zombie! Вход строго по приглашениям! Ссылка для строгих приглашений: https://t.me/joinchat/AAMBHz3Uyr0tuZ7VaB029g

All That JS
All That JS
417 участник(ов)

JS на русском