Get exchange rates - help me update URL in Excel V

问题:

I was using this VBA code that was working, now the function returns 0 because the URL has changed. What URL should I use now?

Thank you very much.

Function YahooCurrencyConverter(ByVal strFromCurrency, ByVal strToCurrency, Optional ByVal strResultType = "Value")
    On Error GoTo ErrorHandler

'Init
Dim strURL As String
Dim objXMLHttp As Object
Dim strRes As String, dblRes As Double

Set objXMLHttp = CreateObject("MSXML2.ServerXMLHTTP")
strURL = "http://finance.yahoo.com/d/quotes.csv?e=.csv&f=c4l1&s=" & strFromCurrency & strToCurrency & "=X"

'Send XML request
With objXMLHttp
    .Open "GET", strURL, False
    .setRequestHeader "Content-Type", "application/x-www-form-URLEncoded"
    .Send
    strRes = .ResponseText
End With

'Parse response
dblRes = Val(Split(strRes, ",")(1))

Select Case strResultType
    Case "Value": YahooCurrencyConverter = dblRes
    Case Else: YahooCurrencyConverter = "1 " & strFromCurrency & " = " & dblRes & " " & strToCurrency
End Select

CleanExit:
    Set objXMLHttp = Nothing

Exit Function

ErrorHandler:
    YahooCurrencyConverter = 0
    GoTo CleanExit
End Function

回答1:

Split:

Now you have obtained the JSON string you can parse with Split function. Here I am reading the JSON in the comments from a cell

Option Explicit
Public Sub GetExchangeRate()
    Dim json As String
    json = [A1]
    Debug.Print Split(Split(json, """5. Exchange Rate"": ")(1), ",")(0)
End Sub

---

JSON Parser:

Here you can use a JSON parser, JSONConverter.bas and then add a reference via VBE > Tools > References > Microsoft Scripting Dictionary

Public Sub GetRate()
    Dim jsonStr As String, json As Object
    jsonStr = [A1]
    Debug.Print JsonConverter.ParseJson(jsonStr)("Realtime Currency Exchange Rate")("5. Exchange Rate")
End Sub

This is the path to your desired change rate:

The initial object is a dictionary containing another dictionary. Dictionaries are denoted by {}. You access the first dictionary with the key Realtime Currency Exchange Rate and then the required value, from the inner dictionary, by the associated key: 5. Exchange Rate

---

Whole request with JSON parser:

Option Explicit
Public Sub GetRate2()
    Dim URL As String, json As String, http As Object
    URL = "https://www.alphavantage.co/query?function=CURRENCY_EXCHANGE_RATE&from_currency=EUR&to_currency=USD&apikey=yourAPIkey"
    Set http = CreateObject("MSXML2.XMLHTTP")
    With http
        .Open "GET", URL, False
        .setRequestHeader "If-Modified-Since", "Sat, 1 Jan 2000 00:00:00 GMT"
        .send
        json = .responseText
    End With
    Debug.Print JsonConverter.ParseJson(json)("Realtime Currency Exchange Rate")("5. Exchange Rate")
End Sub

---

As an UDF:

Option Explicit
Public Sub Test()
    Debug.Print CurrencyConverter("EUR", "USD")
End Sub

Public Function CurrencyConverter(ByVal FromCurrency, ByVal ToCurrency) As String
    Dim URL As String, json As String, http As Object
    URL = "https://www.alphavantage.co/query?function=CURRENCY_EXCHANGE_RATE&from_currency=" & FromCurrency & "&to_currency=" & ToCurrency & "&apikey=yourAPIkey"

    Set http = CreateObject("MSXML2.XMLHTTP")
    With http
        .Open "GET", URL, False
        .setRequestHeader "If-Modified-Since", "Sat, 1 Jan 2000 00:00:00 GMT"
        .send
        json = .responseText
    End With
    CurrencyConverter = JsonConverter.ParseJson(json)("Realtime Currency Exchange Rate")("5. Exchange Rate")
'CurrencyConverter = Replace$(JsonConverter.ParseJson(json)("Realtime Currency Exchange Rate")("5. Exchange Rate"), Application.DecimalSeparator, ".") 
End Function

To use split function replace penultimate function line with

CurrencyConverter = Replace$(Split(Split(json, """5. Exchange Rate"": ")(1), ",")(0), Chr$(34), vbNullString)

回答2:

Using a JSON parser:

Option Explicit
Function EURtoUSD() As Currency
    Const myAPI As String = "apikey=your_key"
    Const sURL As String = "https://www.alphavantage.co/query?function=CURRENCY_EXCHANGE_RATE&from_currency=EUR&to_currency=USD&"
    Const DOL As Currency = 1
    Dim httpRequest As WinHttpRequest
    Dim strJSON As String, JSON As Object

Set httpRequest = New WinHttpRequest
With httpRequest
    .Open "Get", sURL & myAPI
    .send
    .WaitForResponse
    strJSON = .responseText
End With
Set httpRequest = Nothing

Set JSON = ParseJson(strJSON)

EURtoUSD = JSON("Realtime Currency Exchange Rate")("5. Exchange Rate") * DOL

End Function

Or, you could used Power Query to set up a refreshable data connection

You can set up the Query in the UI by entering the URL. After you run it, edit the query by

• convert to table
  • expand the table selecting only the columns you want to keep
  • deselect the option to use the original column name

After you do this, you can refresh the query whenever you want with a single button press.

This is the M-code generated by the UI. I chose to also keep the Time Updated column:

let
    Source = Json.Document(Web.Contents("https://www.alphavantage.co/query?" & "function=CURRENCY_EXCHANGE_RATE" & "&from_currency=EUR" & "&to_currency=USD" & "&apikey=your_api")),
    #"Converted to Table" = Record.ToTable(Source),
    #"Expanded Value" = Table.ExpandRecordColumn(#"Converted to Table", "Value", {"5. Exchange Rate", "6. Last Refreshed"}, {"5. Exchange Rate", "6. Last Refreshed"}),
    #"Changed Type" = Table.TransformColumnTypes(#"Expanded Value",{{"5. Exchange Rate", Currency.Type}})
in
    #"Changed Type"