My function ExchangeRatesCbr returns a four dimensional array of the currencies listed and their current exchange rate:
' Retrieve the current exchange rates from the Central Bank of the Russian
' Federation having RUB as the base currency.
' The rates are returned as an array and cached until the next update.
' The rates are updated once a day at about UTC 13:00.
'
' Source:
' https://cbr.ru/eng/currency_base/daily/
'
' Note:
' The Central Bank of the Russian Federation has set the exchange rates of
' foreign currencies against the ruble without assuming any liability to
' buy or sell foreign currency at the rates.
'
' Example:
' Dim Rates As Variant
' Rates = ExchangeRatesCbr()
' Rates(9, 0) -> 2018-10-06 ' Publishing date.
' Rates(9, 1) -> "DKK" ' Currency code.
' Rates(9, 2) -> 10.2697 ' Exchange rate.
' Rates(9, 3) -> "Danish Krone" ' Currency name in English.
'
' 2018-10-07. Gustav Brock, Cactus Data ApS, CPH.
'
Public Function ExchangeRatesCbr( _
Optional ByVal LanguageCode As String) _
As Variant
' Operational constants.
'
' API endpoints.
Const RuServiceUrl As String = "https://cbr.ru/currency_base/daily/"
Const EnServiceUrl As String = "https://cbr.ru/eng/currency_base/daily/"
' Functional constants.
'
' Page encoding.
Const Characterset As String = "UTF-8"
' Async setting.
Const Async As Variant = False
' Class name of data table.
Const DataClassName As String = "data"
' Field items of html table.
Const CodeField As Integer = 1
Const NameField As Integer = 3
Const UnitField As Integer = 2
Const RateField As Integer = 4
' Locater/header for publishing date: "DT":".
Const DateHeader As String = """DT"":"""
' Length of formatted date: 2000-01-01.
Const DateLength As Integer = 10
' Update hour (UTC).
Const UpdateHour As Date = #1:00:00 PM#
' Update interval: 24 hours.
Const UpdatePause As Integer = 24
' English language code.
Const EnglishCode As String = "en"
' Russion language code.
Const RussianCode As String = "ru"
#If EarlyBinding Then
' Microsoft XML, v6.0.
Dim XmlHttp As MSXML2.ServerXMLHTTP60
' Microsoft ActiveX Data Objects 6.1 Library.
Dim Stream As ADODB.Stream
' Microsoft HTML Object Library.
Dim Document As MSHTML.HTMLDocument
Dim Scripts As MSHTML.IHTMLElementCollection
Dim Script As MSHTML.HTMLHtmlElement
Dim Tables As MSHTML.IHTMLElementCollection
Dim Table As MSHTML.HTMLHtmlElement
Dim Rows As MSHTML.IHTMLElementCollection
Dim Row As MSHTML.HTMLHtmlElement
Dim Fields As MSHTML.IHTMLElementCollection
Set XmlHttp = New MSXML2.ServerXMLHTTP60
Set Stream = New ADODB.Stream
Set Document = New MSHTML.HTMLDocument
#Else
Dim XmlHttp As Object
Dim Stream As Object
Dim Document As Object
Dim Scripts As Object
Dim Script As Object
Dim Tables As Object
Dim Table As Object
Dim Rows As Object
Dim Row As Object
Dim Fields As Object
Set XmlHttp = CreateObject("MSXML2.ServerXMLHTTP")
Set Stream = CreateObject("ADODB.Stream")
Set Document = CreateObject("htmlfile")
#End If
Static Rates() As Variant
Static LastCall As Date
Static LastCode As String
Dim ServiceUrl As String
Dim RateCount As Integer
Dim Published As String
Dim ValueDate As Date
Dim ThisCall As Date
Dim Text As String
Dim Index As Integer
Dim Unit As Double
Dim ScaledRate As Double
Dim TrueRate As Double
If StrComp(LanguageCode, RussianCode, vbTextCompare) = 0 Then
LanguageCode = RussianCode
ServiceUrl = RuServiceUrl
Else
LanguageCode = EnglishCode
ServiceUrl = EnServiceUrl
End If
If LastCode = LanguageCode And DateDiff("h", LastCall, UtcNow) < UpdatePause Then
' Return cached rates.
Else
' Retrieve updated rates.
' Define default result array.
' Redim for four dimensions: date, code, rate, name.
ReDim Rates(0, 0 To 3)
Rates(0, RateDetail.Date) = NoValueDate
Rates(0, RateDetail.Code) = NeutralCode
Rates(0, RateDetail.Rate) = NeutralRate
Rates(0, RateDetail.Name) = NeutralName
' Retrieve data.
XmlHttp.Open "GET", ServiceUrl, Async
XmlHttp.Send
If XmlHttp.Status = HttpStatus.OK Then
' Retrieve and convert the page.
' The default character set cannot be used. See:
' https://stackoverflow.com/a/23812869/3527297
' Write the raw bytes to the stream.
Stream.Open
Stream.Type = adTypeBinary
Stream.Write XmlHttp.responseBody
' Read text characters from the stream applying the character set.
Stream.Position = 0
Stream.Type = adTypeText
Stream.Charset = Characterset
' Copy the page to the document object.
Document.body.innerHTML = Stream.ReadText
' Search the scripts to locate the publishing date.
Set Scripts = Document.getElementsByTagName("script")
ValueDate = Date
For Each Script In Scripts
Text = Script.innerHTML
If InStr(Text, "uniDbQuery_Data =") > 0 Then
Published = Left(Split(Text, DateHeader)(1), DateLength)
If IsDate(Published) Then
ValueDate = CDate(Published)
End If
Exit For
End If
Next
' Search the tables to locate the data table.
' Doesn't work with late binding.
' Set Tables = Document.getElementsByClassName("data")
Set Tables = Document.getElementsByTagName("table")
For Each Table In Tables
If Table.className = DataClassName Then
Exit For
End If
Next
If Not Table Is Nothing Then
' The table was found.
Set Rows = Table.getElementsByTagName("tr")
' Reduce the count by one to skip the header row.
RateCount = Rows.Length - 1
' Redim for four dimensions: date, code, rate, name.
ReDim Rates(0 To RateCount - 1, 0 To 3)
' Fill the array of rates.
For Index = LBound(Rates, 1) To UBound(Rates, 1)
' Offset Index by one to skip the header row.
Set Row = Rows.Item(Index + 1)
' Get the fields of this rate.
Set Fields = Row.getElementsByTagName("td")
' The returned rates are scaled to hold four decimals only.
' Calculate the true (non-scaled) rate.
ScaledRate = Val(Replace(Fields.Item(RateField).innerText, ",", "."))
Unit = Val(Fields.Item(UnitField).innerText)
TrueRate = ScaledRate / Unit
Rates(Index, RateDetail.Date) = ValueDate
Rates(Index, RateDetail.Code) = Fields.Item(CodeField).innerText
Rates(Index, RateDetail.Rate) = TrueRate
Rates(Index, RateDetail.Name) = Fields.Item(NameField).innerHTML
Next
End If
ThisCall = ValueDate + UpdateHour
' Record requested language and publishing time of retrieved rates.
LastCode = LanguageCode
LastCall = ThisCall
End If
End If
ExchangeRatesCbr = Rates
End Function
From this you can select the currency you are interested in, or you can use the helper function, CurrencyConvertCbr, to pick the currency and conversion factor directly:
' Returns the current conversion factor from Rubel to another currency based on
' the official exchange rates published by the Central Bank of the Russian
' Federation.
'
' Optionally, the conversion factor can be calculated from any other of the
' published exchange rates. Exchange rates from or to other currencies than
' RUB are calculated from RUB by triangular calculation.
'
' If an invalid or unpublished currency code is passed, a conversion factor
' of zero is returned.
'
' Examples, typical:
' CurrencyConvertCbr("DKK") -> 0.0973738278625471
' CurrencyConvertCbr("DKK", "EUR") -> 7.46477501777072
' CurrencyConvertCbr("AUD") -> 0.021253081696846
' CurrencyConvertCbr("AUD", "DKK") -> 0.2182627731021
' CurrencyConvertCbr("DKK", "AUD") -> 4.58163334858857
' CurrencyConvertCbr("EUR", "DKK") -> 0.133962510272498
' CurrencyConvertCbr("", "DKK") -> 10.2697
' CurrencyConvertCbr("EUR") -> 0.013044442415309
' Examples, neutral code.
' CurrencyConvertCbr("AUD", "XXX") -> 1
' CurrencyConvertCbr("XXX", "AUD") -> 1
' CurrencyConvertCbr("XXX") -> 1
' Examples, invalid code.
' CurrencyConvertCbr("XYZ") -> 0
' CurrencyConvertCbr("DKK", "XYZ") -> 0
'
' 2018-10-07. Gustav Brock, Cactus Data ApS, CPH.
'
Public Function CurrencyConvertCbr( _
ByVal IsoTo As String, _
Optional ByVal IsoFrom As String = RubelCode) _
As Double
Dim Rates() As Variant
Dim RateTo As Double
Dim RateFrom As Double
Dim Factor As Double
Dim Index As Integer
If IsoFrom = "" Then
IsoFrom = RubelCode
End If
If IsoTo = "" Then
IsoTo = RubelCode
End If
If IsoTo = NeutralCode Or IsoFrom = NeutralCode Then
Factor = NeutralRate
ElseIf IsoTo = IsoFrom Then
Factor = NeutralRate
Else
Rates() = ExchangeRatesCbr
If IsoTo = RubelCode Then
RateTo = NeutralRate
Else
For Index = LBound(Rates) To UBound(Rates)
If Rates(Index, RateDetail.Code) = IsoTo Then
RateTo = Rates(Index, RateDetail.Rate)
Exit For
End If
Next
End If
If RateTo > NoRate Then
If IsoFrom = RubelCode Then
RateFrom = NeutralRate
Else
For Index = LBound(Rates) To UBound(Rates)
If Rates(Index, RateDetail.Code) = IsoFrom Then
RateFrom = Rates(Index, RateDetail.Rate)
Exit For
End If
Next
End If
Factor = RateFrom / RateTo
End If
End If
CurrencyConvertCbr = Factor
End Function
To retrieve the rates for a historic date, apply the last parameter, for example for 2020-11-02, as shown here:
https://cbr.ru/eng/currency_base/daily/?UniDbQuery.Posted=True&UniDbQuery.To=02%2F11%2F2020
That my function won't do, but it should be easy for you to adjust.
Full source at GitHub: VBA.CurrencyExchange
Disclosure: The linked page contains extensive code written by me only.
