Как исправить и извлечь результаты API Google CSE JSON с помощью Excel VBA

Question

Я новичок здесь.Попытка извлечь с моим кодом VBA, который был предоставлен другом.Но он не очень хорош в JSON.Я попробовал поиск здесь по этому конкретному коду.Не удалось найти правильный код.

Здесь я пытаюсь извлечь только заголовок, URL и описание всех результатов.

https://www.googleapis.com/customsearch/v1?alt=json&cx=016252715861662448569:taxvfdziuic&num=10&start=1&key=APIKey&q= "менеджер по продажам"

'Reference for early binding: Microsoft XML v6.0

Public Sub Custom_Search_All()

Dim URLsSheet As Worksheet, resultsSheet As Worksheet
Dim lastRow As Long, r As Long
Dim result As Variant
Dim lst As IXMLDOMNodeList
Dim rownum As Long
rownum = 4
Set URLsSheet = ThisWorkbook.Worksheets("Sheet2")
Set resultsSheet = ThisWorkbook.Worksheets("Sheet1")
resultsSheet.Cells.ClearContents
resultsSheet.Range("A3:D3").Value = Array("Title", "Link", "Summary", "Updated")

With URLsSheet
    lastRow = .Cells(Rows.Count, "A").End(xlUp).Row
    For r = 2 To lastRow
        Set lst = Google_CSE1(.Cells(r, "A").Value)
        For i = 0 To lst.Length - 1
            result = GetNodeValues(lst(i))
            resultsSheet.Cells(rownum, "A").Resize(1, UBound(result)).Value = result
            rownum = rownum + 1
        Next
    Next
    ReplaceTags resultsSheet
    resultsSheet.Range("A3").Select
End With
End Sub

Public Function GetNodeValues(node As IXMLDOMNode) As Variant
Dim results(1 To 4) As String
results(1) = node.SelectSingleNode("a:title").Text
results(2) = node.SelectSingleNode("a:link").Attributes.getNamedItem("href").Text
results(3) = Replace(node.SelectSingleNode("a:summary").Text, vbLf, " ") 'remove multiple line chars
results(4) = Cvt_ISO8601DT_Excel(node.SelectSingleNode("a:updated").Text)
GetNodeValues = results
End Function

Public Function Google_CSE1(queryURL As String) As IXMLDOMNodeList

Static XMLdoc As DOMDocument60
Dim lst As IXMLDOMNodeList

'https://developers.google.com/custom-search/json-api/v1/reference/cse/list
'
'The cse.list method returns metadata about the search performed, metadata about the custom search engine used for the search, and the search results.
'
'This method requires three query parameters:
'
'   The search engine to use in your request (using the cx query parameter)
'   The search terms for in this request (using the q query parameter).
'   Your API key (using the key query parameter).

If XMLdoc Is Nothing Then Set XMLdoc = New DOMDocument60
With XMLdoc

    'How To Specify Namespace when Querying the DOM with XPath - https://support.microsoft.com/en-us/help/294797

    'Search response starts with the following XML:
    '< ?xml version="1.0" encoding="UTF-8"? >
    '< feed gd:kind="customsearch#search" xmlns="http://www.w3.org/2005/Atom" xmlns:cse="http://schemas.google.com/cseapi/2010"
    'xmlns:gd="http://schemas.google.com/g/2005" xmlns:opensearch="http://a9.com/-/spec/opensearch/1.1/" >

    XMLdoc.async = False
    XMLdoc.validateOnParse = False
    XMLdoc.SetProperty "SelectionLanguage", "XPath"
    XMLdoc.SetProperty "SelectionNamespaces", "xmlns:a='http://www.w3.org/2005/Atom'"
    XMLdoc.Load queryURL
End With
Set lst = XMLdoc.SelectNodes("/a:feed/a:entry")
Set Google_CSE1 = lst

End Function

Private Function Cvt_ISO8601DT_Excel(dt As String) As Date

'Convert ISO8601 date time UTC (in the format yyyy-mm-ddthh-mm-ssz) to an Excel date-time
'                                             1234567890123456789
'https://en.wikipedia.org/wiki/ISO_8601#UTC

Cvt_ISO8601DT_Excel = DateSerial(Mid(dt, 1, 4), Mid(dt, 6, 2), Mid(dt, 9, 2)) + TimeSerial(Mid(dt, 12, 2), Mid(dt, 15, 2), Mid(dt, 18, 2))

End Function

Sub ReplaceTags(sht As Worksheet)
sht.Activate
sht.Columns("C:C").Select
Selection.Replace What:="<b>", Replacement:="", LookAt:=xlPart, _
    SearchOrder:=xlByColumns, MatchCase:=False, SearchFormat:=False, _
    ReplaceFormat:=False
Selection.Replace What:="</b>", Replacement:="", LookAt:=xlPart, _
    SearchOrder:=xlByColumns, MatchCase:=False, SearchFormat:=False, _
    ReplaceFormat:=False
Selection.Replace What:="<br>", Replacement:="", LookAt:=xlPart, _
    SearchOrder:=xlByColumns, MatchCase:=False, SearchFormat:=False, _
    ReplaceFormat:=False
Selection.Replace What:="&nbsp;...", Replacement:="", LookAt:=xlPart, _
    SearchOrder:=xlByColumns, MatchCase:=False, SearchFormat:=False, _
    ReplaceFormat:=False
Selection.Replace What:="...", Replacement:="", LookAt:=xlPart, _
    SearchOrder:=xlByColumns, MatchCase:=False, SearchFormat:=False, _
    ReplaceFormat:=False
End Sub

@ QHarr Ваш сценарий не может обрабатывать двоеточие, двойные кавычки и не пропускает URL-адреса, если по определенным URL-адресам нет данных.Он также не показывает, по каким URL он завершил извлечение данных.

Буду признателен, если кто-нибудь сможет мне помочь в этом.

Answer 1

Это json, поэтому анализируйте как json

. Вы можете использовать это с XMLHTTPRequest , чтобы получить данные JSON и затем проанализировать ответ с помощью такого инструмента, как JSONConverter ,После того, как вы добавили .bas в свой проект, вам нужно перейти в VBE> Инструменты> Ссылки и добавить ссылку на Microsoft Scripting Runtime.

В VBA Json [] - это коллекции, которые вы For Each over / accessпо индексу;{} - это словари, к которым вы обращаетесь по ключу.

Ниже приведены пути доступа и способы эффективного хранения и записи результатов.Я предположил, что summary является snippet.Легко изменить этот ключ, если требуется.

TODO: Возможно, вы захотите обработать случаи, когда нет элементов;http-коды ответов не 200 и т. д.

Предполагается, что в столбце A на листе 1 содержатся поисковые термины в каждой ячейке, например, менеджер по продажам Android-разработчик, а в столбце B - объединение базового URL с поисковыми запросами, закодированными в URL-адресе.

Макет:

Col Col с ключевыми словами (может потребоваться объединить их с + между), а B имеет строку базового URL:

"https://www.googleapis.com/customsearch/v1?alt=json&cx=016252715861662448569:taxvfdziuic&num=10&start=1&key=yourAPIkey&q="

, в который вы добавляете закодированные URL-адреса условия поиска:

="https://www.googleapis.com/customsearch/v1?alt=json&cx=016252715861662448569:taxvfdziuic&num=10&start=1&key=yourAPIkey&q=" & ENCODEURL(A1)

---

VBA:

Option Explicit

Public Sub GetInfo()
    ' VBE > Tools > References > Microsoft Scripting Runtime
    Dim listings As Object, headers(), urls(), final()
    Dim urlSheet As Worksheet, resultSheet As Worksheet, lastRow As Long, i As Long
    Application.ScreenUpdating = True

    Set urlSheet = ThisWorkbook.Worksheets("Sheet1")
    Set resultSheet = ThisWorkbook.Worksheets("Sheet2")
    headers = Array("Title", "Link", "Summary")
    lastRow = urlSheet.Cells(urlSheet.Rows.Count, "A").End(xlUp).Row 'Search terms are in column A
    urls = Application.Transpose(urlSheet.Range("B1:B" & lastRow).Value) ' assumes urls start in row 1

    ReDim final(1 To UBound(urls))

    With CreateObject("MSXML2.XMLHTTP")
        For i = LBound(urls) To UBound(urls)     'make each request with new url
            .Open "GET", urls(i), False
            .send
            Set listings = JsonConverter.ParseJson(.responseText)("items")

            Dim results, listing As Object, r As Long, c As Long
            ReDim results(1 To listings.Count, 1 To 3)
            r = 0
            For Each listing In listings
                r = r + 1
                results(r, 1) = listing("title")
                results(r, 2) = listing("link")
                results(r, 3) = listing("snippet")
            Next
            final(i) = results                   'store current results in final array
        Next
    End With
    Dim arr()
    With resultSheet
        .Cells(1, 1).Resize(1, UBound(headers) + 1) = headers
        For i = LBound(final) To UBound(final)
            arr = final(i)
            .Cells(.Cells(.Rows.Count, "A").End(xlUp).Row + 1, 1).Resize(UBound(arr, 1), UBound(arr, 2)) = arr
        Next
    End With
    Application.ScreenUpdating = True
End Sub