VBA Currency Conversion Function (Historical Date)

[neodjandre]

I have been looking around the internet with no success for a VBA function which will simply take 3 arguments: Currency From, Currency To, Date and output the relevant FX Rate. Has anyone worked with a successful solution?

I am currently using this procedure which works fast but it outputs a table in a sheet. A function would be much more useful. e.g. fx_convert("USD","GBP",30/01/2015)

Public Sub GetTable()
    Dim sResponse As String, html As HTMLDocument, ws As Worksheet, clipboard As Object

    Set ws = ThisWorkbook.Worksheets("Sheet1")

    With CreateObject("MSXML2.XMLHTTP")
        .Open "GET", "https://www.x-rates.com/historical/?from=CAD&amount=1&date=" & Format$(Date - 1, "yyyy-mm-dd"), False
        .setRequestHeader "If-Modified-Since", "Sat, 1 Jan 2000 00:00:00 GMT"
        .send
        sResponse = StrConv(.responseBody, vbUnicode)
    End With

    Set clipboard = GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
    Set html = New HTMLDocument

    With html
        .body.innerHTML = sResponse
        clipboard.SetText .querySelectorAll(".ratesTable").item(1).outerHTML
        clipboard.PutInClipboard
    End With     
    ws.Cells(1, 1).PasteSpecial 
End Sub

many thanks,
Andrew

 

[Rijnsent]

Hi Andrew,

there are a couple of routes you can take, I built a quick&dirty example based on https://api.exchangeratesapi.io/ (see below). After putting that code in a module and saving the workbook (as xls(m)), you can use the function in your sheets. Warning: don't put too many of those functions in your sheet as they seriously slow down the workbook.
Another option is the function I wrote for my cryptocurrency project (it's a bit more elaborate):
https://github.com/krijnsent/crypto_vba -> download the xlsm example file and try the function C_HIST_PRICE , it works for normal currencies (non-crypto) too. The code uses the cryptocompare API to pull in exchange rates and VBA-JSON (https://github.com/VBA-tools/VBA-JSON) to get the right data out.

Good luck!

Koen

Sub TestFX()

Debug.Print GetFxRate("EUR", "CAD", DateSerial(2019, 1, 1))
Debug.Print GetFxRate("USD", "EUR", #4/30/2018#)
Debug.Print GetFxRate("CHF", "JPY", #1/20/2017#)

End Sub

Function GetFxRate(CurrencyIn As String, CurrencyOut As String, Dt As Date) As Double

'https://api.exchangeratesapi.io/history?start_at=2017-12-25&end_at=2018-01-02&symbols=CAD&base=EUR

GetFxRate = 0
'Get 7 days of data as some days might not have data (new year, christmas, etc)
strURL = "https://api.exchangeratesapi.io/history?"
strURL = strURL & "start_at=" & Format(Dt - 7, "yyyy-mm-dd") & "&end_at=" & Format(Dt, "yyyy-mm-dd")
strURL = strURL & "&symbols=" & CurrencyIn & "&base=" & CurrencyOut

Debug.Print strURL  'The Url that is being called

Set objHTTP = CreateObject("WinHttp.WinHttpRequest.5.1")
objHTTP.Open "GET", strURL, False
objHTTP.send
If objHTTP.Status = "200" Then
    objHTTP.WaitForResponse
    WebResponse = objHTTP.responseText
    'e.g. "{"rates":{"2018-12-27":{"EUR":0.6451612903},"2018-12-31":{"EUR":0.6408202499},"2018-12-28":{"EUR":0.6409434688}},"start_at":"2018-12-25","base":"CAD","end_at":"2019-01-01"}"
    StartAtPos = InStr(WebResponse, "start_at")
    For D = Dt To Dt - 7 Step -1
        DtTxt = Format(D, "yyyy-mm-dd")
        DtPos = InStr(WebResponse, DtTxt)
        If DtPos > 0 And DtPos < StartAtPos Then
            ValTxt = Mid(WebResponse, 1 + InStr(DtPos, WebResponse, "{"), InStr(DtPos, WebResponse, "}") - InStr(DtPos, WebResponse, "{") - 1)
            GetFxRate = Val(Right(ValTxt, Len(ValTxt) - InStr(ValTxt, ":")))
            Exit For
        End If
    Next D
End If
Set objHTTP = Nothing

End Function

 

[neodjandre]

Hi Koen,

This is very useful and works as expected.. Hope exchangeratesapi.io don't change their web structure as this presumably will break the function