Давно пользуюсь макросом, откуда стащил - не помню
[vba]
Код
Function GetRate(ByVal CurrencyName As String, ByVal RateDate As Date) As Double ' функция возвращает курс валюты CurrencyName на дату RateDate ' в случае ошибки (неверная дата или название валюты) возвращается 0 On Error Resume Next CurrencyName = UCase(CurrencyName): If Len(CurrencyName) <> 3 Then Exit Function Set xmldoc = CreateObject("Msxml.DOMDocument"): xmldoc.async = False url_request = "http://www.cbr.ru/scripts/XML_daily.asp?date_req=" + Format(RateDate, "dd\/mm\/yyyy")
If xmldoc.Load(url_request) <> True Then Exit Function ' Запрос к серверу ЦБР
' Обработка полученного ответа Set nodeList = xmldoc.SelectNodes("ValCurs"): Set xmlNode = nodeList.Item(0).CloneNode(True) Set node_attr = xmlNode.Attributes(0): strDate = node_attr.Value Set nodeList = xmldoc.SelectNodes("*/Valute") For i = 0 To nodeList.Length - 1 ' поиск нужной валюты Set xmlNode = nodeList.Item(i).CloneNode(True) If xmlNode.ChildNodes(1).Text = CurrencyName Then CurrencyRate = CDbl(xmlNode.ChildNodes(4).Text) divisor = Val(xmlNode.ChildNodes(2).Text) GetRate = CurrencyRate / divisor Exit Function End If Next End Function
[/vba]
Давно пользуюсь макросом, откуда стащил - не помню
[vba]
Код
Function GetRate(ByVal CurrencyName As String, ByVal RateDate As Date) As Double ' функция возвращает курс валюты CurrencyName на дату RateDate ' в случае ошибки (неверная дата или название валюты) возвращается 0 On Error Resume Next CurrencyName = UCase(CurrencyName): If Len(CurrencyName) <> 3 Then Exit Function Set xmldoc = CreateObject("Msxml.DOMDocument"): xmldoc.async = False url_request = "http://www.cbr.ru/scripts/XML_daily.asp?date_req=" + Format(RateDate, "dd\/mm\/yyyy")
If xmldoc.Load(url_request) <> True Then Exit Function ' Запрос к серверу ЦБР
' Обработка полученного ответа Set nodeList = xmldoc.SelectNodes("ValCurs"): Set xmlNode = nodeList.Item(0).CloneNode(True) Set node_attr = xmlNode.Attributes(0): strDate = node_attr.Value Set nodeList = xmldoc.SelectNodes("*/Valute") For i = 0 To nodeList.Length - 1 ' поиск нужной валюты Set xmlNode = nodeList.Item(i).CloneNode(True) If xmlNode.ChildNodes(1).Text = CurrencyName Then CurrencyRate = CDbl(xmlNode.ChildNodes(4).Text) divisor = Val(xmlNode.ChildNodes(2).Text) GetRate = CurrencyRate / divisor Exit Function End If Next End Function
Мне кажется, на сайте ЦБ нет сервиса, выдающего ключевую ставку по дате
Но задача проста как яйцо - есть же даты изменений значений КС, например здесь
Ну и вытаскивайте формулой или макросом
Прототип макроса накидал
[vba]
Код
Public Function Stavka(D As Date) As Double Dim Stavki()
ChangeDates = "13.09.13,02.03.14,28.04.14,28.07.14" Stavki = Array(5.5, 7, 7.5, 8) If D < CDate(Mid(ChangeDates, 1, 8)) Then Stavka = 0 Exit Function End If For i = 0 To UBound(Stavki) - 1 If D >= CDate(Mid(ChangeDates, i * 9 + 1, 8)) And D < CDate(Mid(ChangeDates, i * 9 + 10, 8)) Then Stavka = Stavki(i) Exit Function End If Next i Stavka = Stavki(UBound(Stavki)) End Function
[/vba]
Мне кажется, на сайте ЦБ нет сервиса, выдающего ключевую ставку по дате
Но задача проста как яйцо - есть же даты изменений значений КС, например здесь
Ну и вытаскивайте формулой или макросом
Прототип макроса накидал
[vba]
Код
Public Function Stavka(D As Date) As Double Dim Stavki()
ChangeDates = "13.09.13,02.03.14,28.04.14,28.07.14" Stavki = Array(5.5, 7, 7.5, 8) If D < CDate(Mid(ChangeDates, 1, 8)) Then Stavka = 0 Exit Function End If For i = 0 To UBound(Stavki) - 1 If D >= CDate(Mid(ChangeDates, i * 9 + 1, 8)) And D < CDate(Mid(ChangeDates, i * 9 + 10, 8)) Then Stavka = Stavki(i) Exit Function End If Next i Stavka = Stavki(UBound(Stavki)) End Function