Альтернатива формуле WEBSERVICE (функция VBA)

Question

Я использую функцию WEBSERVICE на своем листе для получения данных из файла XML. Есть ли какая-либо альтернатива этому, поскольку корпоративная политика по умолчанию блокирует формулу WEBSERVICE, и ее необходимо включать вручную каждый раз, когда я открываю свою книгу («Включить содержимое»).

В настоящее время я использую WEBSERVICE, чтобы получать данные о расстоянии и часах поездки от Google Maps.

Вывод из Google Maps XML:

<DistanceMatrixResponse>
<status>OK</status>
<origin_address>London, UK</origin_address>
<destination_address>Manchester, UK</destination_address>
<row>
<element>
<status>OK</status>
<duration>
<value>14735</value>
<text>4 hours 6 mins</text>
</duration>
<distance>
<value>335534</value>
<text>336 km</text>
</distance>
</element>
</row>
</DistanceMatrixResponse>

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

Кроме того, я хотел бы получить курсы валют в ЕЦБ. https://www.ecb.europa.eu/stats/eurofxref/eurofxref-daily.xml

WEBSERVICE вообще не работает с ECB XML, например, потому что он заблокирован корпоративной политикой. Поэтому я подумал, поможет ли это как-нибудь, если в Workbook будет альтернативная функция VBA.

---

EDIT:

С помощью QHarr я заработал:

Sub XmlHttpTutorial()
Dim xmlhttp As Object
Set xmlhttp = CreateObject("MSXML2.serverXMLHTTP")
Dim myurl As String
myurl = "https://www.ecb.europa.eu/stats/eurofxref/eurofxref-daily.xml" 'replace with your URL
xmlhttp.Open "GET", myurl, False
xmlhttp.Send
ThisWorkbook.Worksheets("Sheet1").Range("A1") = xmlhttp.responseText
End Sub

Единственный оставшийся вопрос - как вставить его как в исходном XML-файле, чтобы он выглядел как в таблице Excel, начиная с ячейки A1 (не весь XML в одной ячейке):

<gesmes:Envelope xmlns:gesmes="http://www.gesmes.org/xml/2002-08-01" xmlns="http://www.ecb.int/vocabulary/2002-08-01/eurofxref">
<gesmes:subject>Reference rates</gesmes:subject>
<gesmes:Sender>
<gesmes:name>European Central Bank</gesmes:name>
</gesmes:Sender>
<Cube>
<Cube time="2019-06-26">
<Cube currency="USD" rate="1.1362"/>
<Cube currency="JPY" rate="122.40"/>
<Cube currency="BGN" rate="1.9558"/>
<Cube currency="CZK" rate="25.486"/>
<Cube currency="DKK" rate="7.4651"/>
<Cube currency="GBP" rate="0.89603"/>
<Cube currency="HUF" rate="323.50"/>
<Cube currency="PLN" rate="4.2627"/>
<Cube currency="RON" rate="4.7220"/>
<Cube currency="SEK" rate="10.5435"/>
<Cube currency="CHF" rate="1.1113"/>
<Cube currency="ISK" rate="141.50"/>
<Cube currency="NOK" rate="9.6733"/>
<Cube currency="HRK" rate="7.3956"/>
<Cube currency="RUB" rate="71.6399"/>
<Cube currency="TRY" rate="6.5500"/>
<Cube currency="AUD" rate="1.6277"/>
<Cube currency="BRL" rate="4.3624"/>
<Cube currency="CAD" rate="1.4947"/>
<Cube currency="CNY" rate="7.8139"/>
<Cube currency="HKD" rate="8.8724"/>
<Cube currency="IDR" rate="16097.68"/>
<Cube currency="ILS" rate="4.0825"/>
<Cube currency="INR" rate="78.5705"/>
<Cube currency="KRW" rate="1312.86"/>
<Cube currency="MXN" rate="21.7972"/>
<Cube currency="MYR" rate="4.7124"/>
<Cube currency="NZD" rate="1.7004"/>
<Cube currency="PHP" rate="58.456"/>
<Cube currency="SGD" rate="1.5387"/>
<Cube currency="THB" rate="34.955"/>
<Cube currency="ZAR" rate="16.2802"/>
</Cube>
</Cube>
</gesmes:Envelope>

Answer 1

1) Использование html-файла с поздней привязкой

Нижеследующее намеренно устанавливается с использованием ссылок с поздней привязкой с учетом отмеченных вами ограничений.

Option Explicit

Public Sub GetRates()
    Dim headers(), r As Long, html As Object, listings As Object, re As Object, p As String
    p = "time=""(.*?)"""
    Set re = CreateObject("VBScript.RegExp")

    headers = Array("currency", "rate")
    Set html = CreateObject("htmlfile")

    With CreateObject("MSXML2.ServerXMLHTTP")
        .Open "GET", "https://www.ecb.europa.eu/stats/eurofxref/eurofxref-daily.xml", False
        .send
        html.body.innerHTML = .responseText
    End With

    Set listings = html.getElementsByTagName("Cube")
    Dim results(), item As Long, dateVar As String
    ReDim results(1 To 50, 1 To 2)
    For item = 2 To listings.Length - 1
        r = r + 1
        results(r, 1) = listings(item).getAttribute("currency")
        results(r, 2) = listings(item).getAttribute("rate")
    Next
    With ThisWorkbook.Worksheets("Sheet1")
        With re
            .Global = True
            .Pattern = p
            dateVar = .Execute(listings(0).outerHTML)(0).SubMatches(0)
        End With
        .Cells(1, 1) = dateVar
        .Cells(3, 1).Resize(1, UBound(headers) + 1) = headers
        .Cells(4, 1).Resize(UBound(results, 1), UBound(results, 2)) = results
    End With
End Sub

---

2) Использование парсера xml.Предпочтение.

Option Explicit
Public Sub test()
    Const URL As String = "https://www.ecb.europa.eu/stats/eurofxref/eurofxref-daily.xml"
    Dim sResponse As String, xmlDoc As Object    'MSXML2.DOMDocument60

    Set xmlDoc = CreateObject("MSXML2.DOMDocument") 'New MSXML2.DOMDocument60

    With CreateObject("MSXML2.ServerXMLHTTP")
        .Open "GET", URL, False
        .send
        sResponse = .responseText
    End With

    With xmlDoc
        .validateOnParse = True
        .setProperty "SelectionLanguage", "XPath"
        .async = False

        If Not .LoadXML(sResponse) Then
            Err.Raise .parseError.ErrorCode, , .parseError.reason
        End If

        Dim dateVar As String, results(), rates As Object, rate As Object, r As Long
        dateVar = xmlDoc.SelectSingleNode("//@time").Text
        Set rates = xmlDoc.SelectNodes("//*[@currency]")
        ReDim results(1 To rates.Length, 1 To 2)
        For Each rate In rates
            r = r + 1
            results(r, 1) = rate.getAttribute("currency")
            results(r, 2) = rate.getAttribute("rate")
        Next
        Dim headers()
        headers = Array("currency", "rate")
        With ThisWorkbook.Worksheets("Sheet1")
            .Cells(1, 1) = dateVar
            .Cells(3, 1).Resize(1, UBound(headers) + 1) = headers
            .Cells(4, 1).Resize(UBound(results, 1), UBound(results, 2)) = results
        End With
    End With
End Sub