Я хочу получить таблицу из URL-адреса https://s.cafef.vn/screener. aspx # data с помощью VBA. Эта задача сложна, поскольку таблица содержит данные JSON, встроенные в файл html.

Следуя совету @Tomalak, я пытаюсь разделить свою задачу; решая последовательно четыре следующие индивидуальные задачи:

  1. Отправьте запрос HTTP, чтобы получить HTML
  2. Найдите строку JSON
  3. Разберите JSON с помощью VBA, а затем
  4. Прокрутите необработанные данные из JSON и запишите в таблицу Excel.

Извлеките таблицу данных JSON в HTML с помощью VBA; преобразование скрипта приложений в VBA

Однако я застреваю на шаге 2, текст ответа, который я получаю, сохраняется в htmlTEXT. Его распечатка выглядит, как показано ниже, но проблема заключается в том, что строковая переменная htmlTEXT может содержать только небольшую часть содержимого html-страницы. Абзац JSON не находится в верхней части html-страницы и поэтому не возвращается в htmlTEXT.

Мои вопросы:

  1. Как мы можем получить все содержимое html-страницы (с включенным абзацем JSON)?

  2. После захвата абзаца JSON какое регулярное выражение можно использовать для извлечения абзаца JSON?

Заметив, что абзац JSON начинается с [{ и заканчивается на }], я поэтому использую шаблон [{*}], но он совсем не работает (хотя он работает с шаблоном вроде (D.C); в результате получается DOC для моих целей тестирования)

Что не так с моим кодом?


Sub ExtractJSON_in_html()
    ' =====send an HTTP request with VBA ====
    Dim JSONtext As String
    Dim htmlTEXT As String
    Dim SDI As Object

    Set objHTTP = CreateObject("MSXML2.XMLHTTP")
    Url = "https://s.cafef.vn/screener.aspx#data"
  
    objHTTP.Open "GET", Url, False
    objHTTP.send
    htmlTEXT = objHTTP.responsetext
   
    MsgBox htmlTEXT

    ' ===== Locate the JSON string  =======
    Set SDI = CreateObject("VBScript.RegExp")
    SDI.IgnoreCase = True
    SDI.Pattern = "[{*}]"
    SDI.Global = True

    Set theMatches = SDI.Execute(htmlTEXT)

    For Each Match In theMatches     
        'MsgBox Match.Value
        JSONtext = Match.Value
    Next
End Sub

HtmlТЕКСТ:

<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">

<html xmlns="http://www.w3.org/1999/xhtml">

<head>

<meta http-equiv="Content-Type" content="text/html; charset=iso-8859-1"/>
-- JASON Paragraph var jsonData = [{"Url":"http://s.cafef.vn/upcom/A32-cong-ty-co-phan-32.chn","CenterName":"UpCom","Symbol":"A32","TradeCenterID":9,"ChangePrice":0,"VonHoa":212.84,"ChangeVolume":400,"EPS":6.19220987764706,"PE":5.0547382305287,"Beta":0,"Price":0,"UpdatedDate":"\/Date(1625562652463)\/","FullName":"Công ty cổ phần 32","ParentCategoryId":0
{"Url":"http://s.cafef.vn/upcom/YTC-cong-ty-co-phan-xuat-nhap-khau-y-te-thanh-pho-ho-chi-minh.chn","CenterName":"UpCom","Symbol":"YTC","TradeCenterID":9,"ChangePrice":0,"VonHoa":170.8,"ChangeVolume":200,"EPS":-4.29038514857143,"PE":-14.217837766922,"Beta":0,"Price":0,"UpdatedDate":"\/Date(1625562969277)\/","FullName":"Công ty Cổ phần Xuất nhập khẩu Y tế Thành phố Hồ Chí Minh","ParentCategoryId":0}];
2
Cao Doremi 8 Июл 2021 в 09:53

2 ответа

Лучший ответ

Это вернет строку JSON в качестве объекта Dictionary, с которым вы можете работать:

Вам понадобится JsonConverter (и ссылка на объект Microsoft Scripting Runtime для словаря)

Private Sub Test()
    Dim xmlhttp As Object
    Set xmlhttp = CreateObject("MSXML2.XMLHTTP")
    
    xmlhttp.Open "GET", "https://s.cafef.vn/screener.aspx"
    xmlhttp.send
    
    Dim jsonStr As String
    jsonStr = Mid$(xmlhttp.responseText, InStr(xmlhttp.responseText, "[{"))
    jsonStr = Left$(jsonStr, InStr(jsonStr, "}]") + 1)
    
    Dim jsDict As Scripting.Dictionary
    Set jsDict = JsonConverter.ParseJson("{""results"":" & jsonStr & "}")
    
    Debug.Print jsDict("results").Count '1874
End Sub

Примечание. Исходный URL-адрес в вашем вопросе возвращает ошибку 404, вам просто нужно удалить #data из URL-адреса.

3
Raymond Wu 8 Июл 2021 в 09:31

Отредактировал макрос. Будет добавлен лист и проанализирован текст JSON из диапазона A1.

Option Explicit

Sub ExtractJSON_in_html()
Dim JSONtext As String, JSONtextarr() As String, Url As String
Dim htmlTEXT As String, colHead As String
Dim SDI As Object, objHTTP As Object, theMatches As Object, Match As Variant
Dim StartPos As Long, endPos As Long, i As Long

Set objHTTP = CreateObject("MSXML2.XMLHTTP")
Url = "https://s.cafef.vn/screener.aspx"

' =====send an HTTP request with VBA ====
objHTTP.Open "GET", Url, False
objHTTP.send
htmlTEXT = objHTTP.responseText
StartPos = InStr(1, htmlTEXT, "var jsonData = [", vbTextCompare)
endPos = InStr(StartPos, htmlTEXT, "]", vbTextCompare)
htmlTEXT = Replace(Mid(htmlTEXT, StartPos, endPos - StartPos + 1), ",""", ";")

' ===== Make the JSON strings collecton  =======
Set SDI = CreateObject("VBScript.RegExp")
SDI.IgnoreCase = True
SDI.Global = True


SDI.Pattern = "[^a-zA-Z0-9&{}./:;,-]"
htmlTEXT = SDI.Replace(htmlTEXT, "")

SDI.Pattern = "\{([^}]+)\}"
Set theMatches = SDI.Execute(htmlTEXT)
JSONtext = ""
Debug.Print theMatches.Count
For Each Match In theMatches
    JSONtext = JSONtext & Match.Value & ","
Next

' ===== Populate new worksheet with parsed JSON =======
JSONtext = Replace(Mid(JSONtext, 2, Len(JSONtext) - 3), ",ParentCategoryId", ",,ParentCategoryId", , , vbTextCompare)
JSONtextarr = Split(JSONtext, "},{", , vbTextCompare)
Worksheets.Add
Range("A2").Resize(UBound(JSONtextarr) + 1, 1).Value = Application.Transpose(JSONtextarr)

Range("A2").CurrentRegion.TextToColumns Destination:=Range("A2"), DataType:=xlDelimited, _
    TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
    Semicolon:=True, Comma:=False, Space:=False, Other:=False, TrailingMinusNumbers:=True

Debug.Print Range("A2").CurrentRegion.Columns.Count
For i = 1 To Range("A2").CurrentRegion.Columns.Count
colHead = Split(Cells(2, i), ":")(0)
Cells(1, i) = colHead
Range("A2").CurrentRegion.Columns(i).Replace What:=colHead & ":", Replacement:="", LookAt:=xlPart, _
    SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
    ReplaceFormat:=False
Next i


End Sub
1
Naresh 8 Июл 2021 в 11:01