Как найти и распарсить JSON на странице сайта в интернете с помощью VBA Excel?
В этом посте я покажу, как с помощью VBA сделать, то, для чего VBA вроде бы как изначально не предназначен – как получить значения нужных переменных из структуры JSON.
В чем отличие между сервисом ЦБ России и сайтом worldometers.info? В том, что ЦБ предлагает XML сервис для автоматической загрузки информации (см. http://www.cbr.ru/development/SXML/) – ее неудобно смотреть через веб браузер, но удобно получать с помощью паучьих алгоритмов, а worldometers.info предлагает информацию для людей, а не для пауков.
Поэтому создаваемому на VBA паучку придется постараться, чтобы понять разметку «для людей».
Для работы паука необходимо дополнительно подключить три библиотеки:
- Microsoft XML parser (MSXML) – тот же, что использовался для получения курсов ЦБ с сайта Банка России.
- Библиотеку для работы с объектной моделью HTML.
- Библиотеку для использования возможностей JavaScript из VBA.
Запускаем паучка на сайт: https://www.worldometers.info/coronavirus/coronavirus-cases/
Sub GetJSONformHTML() Dim xmlhttp As New MSXML2.XMLHTTP60, urlWorldometers As String urlWorldometers = "https://www.worldometers.info/coronavirus/coronavirus-cases/" xmlhttp.Open "GET", urlWorldometers, False xmlhttp.setRequestHeader "Content-Type", "text/json" xmlhttp.setRequestHeader "Content-Type", "application/x-www-form-urlencoded" xmlhttp.setRequestHeader "User-Agent", "Mozilla/5.0 (Windows NT 6.3; Win64; x64) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/81.0.4044.138 Safari/537.36" xmlhttp.send
В полученном html паучку нужно найти и распарсить данные о количестве зарегистрированных случаев из формата JSON. Эти данные представлены вторым аргументом в вызове функции Highcharts.chart(chartName, chartData), которая на сайте рисует график.
Dim html As New HTMLDocument html.body.innerHTML = xmlhttp.responseText
В результате выполнения нижепредставленного кода в переменной strJson должна оказаться структура с данными в JSON формате.
Dim scripts As IHTMLDOMChildrenCollection Set scripts = html.querySelectorAll("script") Dim i As Integer, start As Integer, finish As Integer, strJson As String, jsfunc As String Dim strGraph As String strGraph = "Highcharts.chart('coronavirus-cases-linear'," For i = 0 To scripts.Length - 1 start = InStr(scripts(i).innerHTML, strGraph) If start > 0 Then finish = InStr(scripts(i).innerHTML, ");") jsfunc = scripts(i).innerHTML start = start + Len(strGraph) strJson = Mid(jsfunc, start, finish - start) Exit For End If Next
Теперь самое интересное – как распарсить эту JSON структуру? Чистый VBA это делать не умеет. Но с JSON прекрасно работает JavaScript.
А в VBA есть инструмент для использования возможностей JavaScript для пользователей MS Excel.
Dim myJSCript As ScriptControl Set myJSCript = New ScriptControl myJSCript.Language = "JScript"
Мы можем в VBA получить уже распарсенную JSON переменную:
Dim objJSON As Object Set objJSON = myJSCript.Eval("(" + strJson + ")")
Проблема в том, что с объектом objJSON ничего нельзя сделать в рамках VBA – у него нет ни свойств, ни методов. Поэтому создаем эти методы на языке JavaScript. Нам нужно вытащить даты (xAxis) и количество (series->data):
Вот что пишем в VBA редакторе:
myJSCript.AddCode "function getDataSeries(jstruct) " myJSCript.AddCode "function getxAxis(jstruct) "
Загоняем данные в привычные VBA массивы:
Dim v1 As String, v2 As String v1 = myJSCript.Run("getDataSeries", objJSON) v2 = myJSCript.Run("getxAxis", objJSON) Dim x() As String, d() As String x() = Split(v2, ",") d() = Split(v1, ",")
Ну и раскатываем эти массивы по рабочему листу:
For i = 0 To UBound(x) Range("A" & i + 1) = x(i) Range("B" & i + 1) = d(i) Next Set objJSON = Nothing Set scripts = Nothing html.Close Set xmlhttp = Nothing Set myJSCript = Nothing MsgBox "Готово." End Sub
Вот, что получилось в результате на листе рабочей книги:
По этим данным легко построить график, например, такой:
Excel файл с кодом можно скачать здесь. Если будут вопросы – пишите их сюда.
Анализ текста как JSON или XML
В Power Query можно проанализировать содержимое столбца с текстовыми строками, определив содержимое как строку JSON или XML.
Эту операцию синтаксического анализа можно выполнить, нажав кнопку «Синтаксический анализ «, найденную в следующих местах в редакторе Power Query:
- Вкладка преобразования. Эта кнопка преобразует существующий столбец, анализируя его содержимое.
- Добавление вкладки столбцов. Эта кнопка добавит новый столбец в таблицу, анализируя содержимое выбранного столбца.
В этой статье вы будете использовать следующую пример таблицы, содержащую следующие столбцы, которые необходимо проанализировать:
-
SalesPerson — содержит неподпарированные текстовые строки JSON со сведениями о firstName и LastName сотрудника отдела продаж, как показано в следующем примере.
1 USA BI-3316 Пример таблицы выглядит следующим образом.
Цель — проанализировать указанные выше столбцы и развернуть содержимое этих столбцов, чтобы получить эти выходные данные.
Как JSON
Выберите столбец SalesPerson. Затем выберите JSON в раскрывающемся меню синтаксического анализа на вкладке «Преобразование «. Эти действия преобразуют столбец SalesPerson с текстовых строк на наличие значений записи , как показано на следующем рисунке. В ячейке значения записи можно выбрать любое место в ячейке значения записи , чтобы получить подробный просмотр содержимого записи в нижней части экрана.
Щелкните значок развертывания рядом с заголовком столбца SalesPerson . В меню «Развернуть столбцы» выберите только поля FirstName и LastName , как показано на следующем рисунке.
Результат этой операции даст вам следующую таблицу.
Как XML
Выберите столбец «Страна«. Затем нажмите кнопку XML в раскрывающемся меню синтаксического анализа на вкладке «Преобразование «. Эти действия преобразуют столбец «Страна » из текстовых строк в значения таблицы , как показано на следующем рисунке. В ячейке значения таблицы можно выбрать любое место в ячейке значения таблицы , чтобы получить подробный просмотр содержимого таблицы в нижней части экрана.
Щелкните значок развертывания рядом с заголовком столбца Country . В меню «Развернуть столбцы» выберите только поля «Страна » и «Деление «, как показано на следующем рисунке.
Все новые столбцы можно определить как текстовые столбцы. Результат этой операции даст вам выходную таблицу, которую вы ищете.
Как распарсить json в excel
Argument ‘Topic id’ is null or empty
Сейчас на форуме
© Николай Павлов, Planetaexcel, 2006-2023
info@planetaexcel.ru
Использование любых материалов сайта допускается строго с указанием прямой ссылки на источник, упоминанием названия сайта, имени автора и неизменности исходного текста и иллюстраций.
| ООО «Планета Эксел» ИНН 7735603520 ОГРН 1147746834949 |
ИП Павлов Николай Владимирович ИНН 633015842586 ОГРНИП 310633031600071 |
VBA: Парсинг JSON c помощью RegEx в Excel
Всем доброго времени суток. Хочу предложить метод парсинга JSON-строки c помощью RegEx для Excel VBA. В отличие от достаточно известного способа преобразования JSON-строки в объект с помощью ScriptControl:
Sub Vulnerability() ' вредоносная JSON-строка, полученная в ответе web-сервера, имеет доступ к файловой системе и многому другому jsonString = ")()>" ' в данном случае создается файл на диске C:\ Set jsonObj = jsonDecode(jsonString) End Sub Function jsonDecode(jsonString As Variant) Set sc = CreateObject("ScriptControl"): sc.Language = "JScript" Set jsonDecode = sc.Eval("(" + jsonString + ")") End Function данный метод не создает уязвимостей системы. Объекты <> представлены Scripting.Dictionary, что позволяет обращаться к их свойствам и методам: .Count, .Items, .Keys, .Exists(), .Item(). Массивы [] являются обычными VB-массивами с индексацией с нуля, поэтому количество элементов можно определить с помощью UBound(). Ниже привожу код с некоторыми примерами использования:
Option Explicit Sub JsonTest() Dim strJsonString As String Dim varJson As Variant Dim strState As String Dim varItem As Variant ' преобразование JSON-строки в объект ' корневой элемент может быть объектом <> или массивом [] strJsonString = "<""a"":[<>, 0, ""value"", []], b:null>" ParseJson strJsonString, varJson, strState ' проверка структуры шаг за шагом Select Case False ' если хоть одна из проверок неудачна, цепочка прервется Case IsObject(varJson) ' если корневой JSON-элемент является объектом, Case varJson.Exists("a") ' имеющим свойство a, Case IsArray(varJson("a")) ' являющимся массивом Case UBound(varJson("a")) >= 3 ' не менее чем с 4 элементами, Case IsArray(varJson("a")(3)) ' и 4-ый элемент - это массив, Case UBound(varJson("a")(3)) = 0 ' в котором единственный элемент Case IsObject(varJson("a")(3)(0)) ' является объектом, Case varJson("a")(3)(0).Exists("stuff") ' имеющим свойство stuff, Case Else ' тогда вывести значение этого свойства. MsgBox "Проверка структуры шаг за шагом" & vbCrLf & varJson("a")(3)(0)("stuff") End Select ' прямой доступ к свойству при известной структуре MsgBox "Прямой доступ к свойству" & vbCrLf & varJson.Item("a")(3)(0).Item("stuff") ' content ' Обход каждого элемента массива For Each varItem In varJson("a") ' показать структуру элемента MsgBox "Структура элемента:" & vbCrLf & BeautifyJson(varItem) Next ' показать структуру целиком, начиная с корневого элемента MsgBox "Структура целиком, начиная с корневого элемента:" & vbCrLf & BeautifyJson(varJson) End Sub Sub BeautifyTest() ' поместите JSON-строку в файл "desktop\source.json" ' переработанная JSON-строка будет сохранена в файл "desktop\result.json" Dim strDesktop As String Dim strJsonString As String Dim varJson As Variant Dim strState As String Dim strResult As String Dim lngIndent As Long strDesktop = CreateObject("WScript.Shell").SpecialFolders.Item("Desktop") strJsonString = ReadTextFile(strDesktop & "\source.json", -2) ParseJson strJsonString, varJson, strState If strState <> "Error" Then strResult = BeautifyJson(varJson) WriteTextFile strResult, strDesktop & "\result.json", -1 End If CreateObject("WScript.Shell").PopUp strState, 1, , 64 End Sub Sub ParseJson(ByVal strContent As String, varJson As Variant, strState As String) ' strContent - исходная JSON-строка ' varJson - созданный объект или массив, возвращаемый в качестве результата ' strState - строка Object|Array|Error, в зависимости от результата преобразования Dim objTokens As Object Dim objRegEx As Object Dim bMatched As Boolean Set objTokens = CreateObject("Scripting.Dictionary") Set objRegEx = CreateObject("VBScript.RegExp") With objRegEx ' спецификация http://www.json.org/ .Global = True .MultiLine = True .IgnoreCase = True .Pattern = """(?:\\""|[^""])*""(?=\s*(. |\:|\]|\>))" Tokenize objTokens, objRegEx, strContent, bMatched, "str" .Pattern = "(?:[+-])?(?:\d+\.\d*|\.\d+|\d+)e(?:[+-])?\d+(?=\s*(. |\]|\>))" Tokenize objTokens, objRegEx, strContent, bMatched, "num" .Pattern = "(?:[+-])?(?:\d+\.\d*|\.\d+|\d+)(?=\s*(. |\]|\>))" Tokenize objTokens, objRegEx, strContent, bMatched, "num" .Pattern = "\b(?:true|false|null)(?=\s*(. |\]|\>))" Tokenize objTokens, objRegEx, strContent, bMatched, "cst" .Pattern = "\b[A-Za-z_]\w*(?=\s*\:)" ' неспецифицированные имена свойств без кавычек Tokenize objTokens, objRegEx, strContent, bMatched, "nam" .Pattern = "\s" strContent = .Replace(strContent, "") .MultiLine = False Do bMatched = False .Pattern = "\:" Tokenize objTokens, objRegEx, strContent, bMatched, "prp" .Pattern = "\<(?:(. )*)?\>" Tokenize objTokens, objRegEx, strContent, bMatched, "obj" .Pattern = "\[(?:(. )*)?\]" Tokenize objTokens, objRegEx, strContent, bMatched, "arr" Loop While bMatched .Pattern = "^$" ' неспецифицированный массив в качестве корневого элемента If Not (.Test(strContent) And objTokens.Exists(strContent)) Then varJson = Null strState = "Error" Else Retrieve objTokens, objRegEx, strContent, varJson strState = IIf(IsObject(varJson), "Object", "Array") End If End With End Sub Sub Tokenize(objTokens, objRegEx, strContent, bMatched, strType) Dim strKey As String Dim strRes As String Dim lngCopyIndex As Long Dim objMatch As Object strRes = "" lngCopyIndex = 1 With objRegEx For Each objMatch In .Execute(strContent) strKey = "" bMatched = True With objMatch objTokens(strKey) = .Value strRes = strRes & Mid(strContent, lngCopyIndex, .FirstIndex - lngCopyIndex + 1) & strKey lngCopyIndex = .FirstIndex + .Length + 1 End With Next strContent = strRes & Mid(strContent, lngCopyIndex, Len(strContent) - lngCopyIndex + 1) End With End Sub Sub Retrieve(objTokens, objRegEx, strTokenKey, varTransfer) Dim strContent As String Dim strType As String Dim objMatches As Object Dim objMatch As Object Dim strName As String Dim varValue As Variant Dim objArrayElts As Object strType = Left(Right(strTokenKey, 4), 3) strContent = objTokens(strTokenKey) With objRegEx .Global = True Select Case strType Case "obj" .Pattern = ">" Set objMatches = .Execute(strContent) Set varTransfer = CreateObject("Scripting.Dictionary") For Each objMatch In objMatches Retrieve objTokens, objRegEx, objMatch.Value, varTransfer Next Case "prp" .Pattern = ">" Set objMatches = .Execute(strContent) Retrieve objTokens, objRegEx, objMatches(0).Value, strName Retrieve objTokens, objRegEx, objMatches(1).Value, varValue If IsObject(varValue) Then Set varTransfer(strName) = varValue Else varTransfer(strName) = varValue End If Case "arr" .Pattern = ">" Set objMatches = .Execute(strContent) Set objArrayElts = CreateObject("Scripting.Dictionary") For Each objMatch In objMatches Retrieve objTokens, objRegEx, objMatch.Value, varValue If IsObject(varValue) Then Set objArrayElts(objArrayElts.Count) = varValue Else objArrayElts(objArrayElts.Count) = varValue End If varTransfer = objArrayElts.Items Next Case "nam" varTransfer = strContent Case "str" varTransfer = Mid(strContent, 2, Len(strContent) - 2) varTransfer = Replace(varTransfer, "\""", """") varTransfer = Replace(varTransfer, "\\", "\") varTransfer = Replace(varTransfer, "\/", "/") varTransfer = Replace(varTransfer, "\b", Chr(8)) varTransfer = Replace(varTransfer, "\f", Chr(12)) varTransfer = Replace(varTransfer, "\n", vbLf) varTransfer = Replace(varTransfer, "\r", vbCr) varTransfer = Replace(varTransfer, "\t", vbTab) .Global = False .Pattern = "\\u[0-9a-fA-F]" Do While .Test(varTransfer) varTransfer = .Replace(varTransfer, ChrW(("&H" & Right(.Execute(varTransfer)(0).Value, 4)) * 1)) Loop Case "num" varTransfer = Evaluate(strContent) Case "cst" Select Case LCase(strContent) Case "true" varTransfer = True Case "false" varTransfer = False Case "null" varTransfer = Null End Select End Select End With End Sub Function BeautifyJson(varJson As Variant) As String Dim strResult As String Dim lngIndent As Long BeautifyJson = "" lngIndent = 0 BeautyTraverse BeautifyJson, lngIndent, varJson, vbTab, 1 End Function Sub BeautyTraverse(strResult As String, lngIndent As Long, varElement As Variant, strIndent As String, lngStep As Long) Dim arrKeys() As Variant Dim lngIndex As Long Dim strTemp As String Select Case VarType(varElement) Case vbObject If varElement.Count = 0 Then strResult = strResult & "<>" Else strResult = strResult & "" End If Case Is >= vbArray If UBound(varElement) = -1 Then strResult = strResult & "[]" Else strResult = strResult & "[" & vbCrLf lngIndent = lngIndent + lngStep For lngIndex = 0 To UBound(varElement) strResult = strResult & String(lngIndent, strIndent) BeautyTraverse strResult, lngIndent, varElement(lngIndex), strIndent, lngStep If Not (lngIndex = UBound(varElement)) Then strResult = strResult & "," strResult = strResult & vbCrLf Next lngIndent = lngIndent - lngStep strResult = strResult & String(lngIndent, strIndent) & "]" End If Case vbInteger, vbLong, vbSingle, vbDouble strResult = strResult & varElement Case vbNull strResult = strResult & "Null" Case vbBoolean strResult = strResult & IIf(varElement, "True", "False") Case Else strTemp = Replace(varElement, "\""", """") strTemp = Replace(strTemp, "\", "\\") strTemp = Replace(strTemp, "/", "\/") strTemp = Replace(strTemp, Chr(8), "\b") strTemp = Replace(strTemp, Chr(12), "\f") strTemp = Replace(strTemp, vbLf, "\n") strTemp = Replace(strTemp, vbCr, "\r") strTemp = Replace(strTemp, vbTab, "\t") strResult = strResult & """" & strTemp & """" End Select End Sub Function ReadTextFile(strPath As String, lngFormat As Long) As String ' lngFormat -2 - System default, -1 - Unicode, 0 - ASCII With CreateObject("Scripting.FileSystemObject").OpenTextFile(strPath, 1, False, lngFormat) ReadTextFile = "" If Not .AtEndOfStream Then ReadTextFile = .ReadAll .Close End With End Function Sub WriteTextFile(strContent As String, strPath As String, lngFormat As Long) With CreateObject("Scripting.FileSystemObject").OpenTextFile(strPath, 2, True, lngFormat) .Write (strContent) .Close End With End Sub