Вам кода-нибудь хотелось получать курс валюты Центрального Банка прямо из функции в ячейку Excel? Либо вы хотели бы автоматизировать свое приложение написанное на VBA и получать курс валюты автоматически? А ведь это совсем не проблема!
Когда-то мне очень понадобилась такая функция, и теперь я использую ее почти во всех своих приложения написанных на языке VBA. Это очень удобно, курс подтягивается из интернета, с официального сайта ЦБ, по специальной ссылке. И, кстати, структура данных возвращаемых после запроса к данному ресурсу не меняется в течении уже многих лет. Т.е. это стабильный ресурс и его можно использовать. Вы можете адаптировать эту функцию под себя, переписать ее, в общем, пользуйтесь на здоровье.
И да, чуть не забыл, эта функция имеет всего два параметра, т.е. принимает два аргумента : дату и значение валюты в буквенном формате, например, “USD”.
Новая версия функции:
Эту функцию мы разбираем в 15 видеоуроке Углубленного курса по VBA
' Procedure : KursCB
' Author : Основа - Pavel55, коррекция - Alex_ST: 2010-01-28; модификация SemukovAV: 2016-04-10
' URL : ROBOTOBOR.PRO
' Date : 10.04.2016
' Purpose : запрос заданного курса валюты ЦБ на заданную дату
' Notes : По умолчанию - текущая дата
'---------------------------------------------------------------------------------------
'//функция возвращает курс ЦБ исходя из входящих параметров(дата и валюта), если дату не задать первым параметром,...
'//...тогда по умолчанию используется текущая дата локальной машины
Public Function KursCB(Optional ByVal dtDate, Optional ByVal txtCurr) As Double ' query rate ЦБ с сайта ЦБ РФ
'//объявляем переменные
Dim query$, otvet$ '//запрос, ответ на запрос, итоговый курс валюта
Dim oHttp As Object '//объект запроса
If IsMissing(dtDate) Then dtDate = Date '//используем текущую дату локальной машины в случае если дата не определена
On Error Resume Next
If Not IsDate(dtDate) Then dtDate = CDate(dtDate) '//проверяем на тип даты
If Err.Number <> 0 Then Exit Function '//выходим из функции если значение даты не верного типа
query = "http://cbr.ru/currency_base/daily.aspx?date_req=" & dtDate '//формируем запрос, который будем передавать
On Error Resume Next
Set oHttp = CreateObject("MSXML2.XMLHTTP") '//создаем объект для запроса
If Err.Number <> 0 Then Set oHttp = CreateObject("MSXML.XMLHTTPRequest") '//если ошибка используем другой объект для запроса
On Error GoTo ErrorHandler
If oHttp Is Nothing Then Exit Function '//если не смогли создать объект для запроса, тогда выходим из функции
Call oHttp.Open("GET", query, False) 'открываем объект для запроса
oHttp.Send '//отправляем запрос на сервер (сайт)
otvet = UCase(oHttp.responseText) '//полученные ответ запроса преобразуем в верхний регистр, для дальнейшего парсинга
Set oHttp = Nothing '//закрываем объект запроса
'//блок кода парсит строку ответа для получения значения курса валюты////////
Dim startCurr As Integer
Dim startKolvo As Integer
Dim endKolvo As Integer
Dim startKurs As Integer
Dim endKurs As Integer
Dim kursCurr As Double
Dim kolvoCurr As Double
startCurr = InStr(1, otvet, txtCurr, vbTextCompare)
startKolvo = InStr(startCurr + 3, otvet, "<td>", vbTextCompare) + 4
endKolvo = InStr(startKolvo + 1, otvet, "</td>", vbTextCompare) - 1
startKurs = InStr(endKolvo + 12, otvet, "<td>", vbTextCompare) + 4
endKurs = InStr(startKurs, otvet, "</td>", vbTextCompare) - 1
kursCurr = CDbl(Mid(otvet, startKurs, endKurs - startKurs + 1)) '//получаем курс валюты как на сайте ЦБ
kolvoCurr = CDbl(Mid(otvet, startKolvo, endKolvo - startKolvo + 1)) '//получаем кол-во ед. валюты как на сайте ЦБ
'////////////////////////////////////////////////////////////////////////////
KursCB = kursCurr / kolvoCurr '//возвращаем реальный курс валюты за единицу валюты
Exit Function
ErrorHandler: 'Обработчик ошибок получения курса валюты
KursCB = 0
Err.Clear
End Function
Ниже приведена Устаревшая версия функции:
' Procedure : KursCB
' Author : Основа - Pavel55, коррекция - Alex_ST: 2010-01-28; модификация SemukovAV: 2012-06-27
' URL : http://www.planetaexcel.ru/forum.php?thread_id=6870&page_forum=2&allnum_forum=34
' Date : 28.01.2010
' Purpose : запрос заданного курса валюты ЦБ на заданную дату
' Notes : По умолчанию - текущая дата
'---------------------------------------------------------------------------------------
'//функция возвращает курс ЦБ исходя из входящих параметров(дата и валюта), если дату не задать первым параметром,...
'//...тогда по умолчанию используется текущая дата локальной машины
Public Function KursCB(Optional ByVal dtDate, Optional ByVal txtCurr) As Double ' query rate ЦБ с сайта ЦБ РФ
'//объявляем переменные
Dim query$, otvet$, rate$ '//запрос, ответ на запрос, итоговый курс валюта
Dim oHttp As Object '//объект запроса
Dim day$, month$, year$ '//дата разбитая на три части: день, месяц, год
If IsMissing(dtDate) Then dtDate = Date '//используем текущую дату локальной машины в случае если дата не определена
On Error Resume Next
If Not IsDate(dtDate) Then dtDate = CDate(dtDate) '//проверяем на тип даты
If Err.Number <> 0 Then Exit Function '//выходим из функции если значение даты не верного типа
day = Format(dtDate, "dd") : month = Format(dtDate, "mm") : year = Format(dtDate, "yyyy")
'//формируем запрос, который будем передавать
query = "http://cbr.ru/currency_base/daily.aspx?C_month=" & month & "&C_year=" _
& year & "&date_req=" & day & "%2F" & month & "%2F" & year
On Error Resume Next
Set oHttp = CreateObject("MSXML2.XMLHTTP") '//создаем объект для запроса
If Err.Number <> 0 Then Set oHttp = CreateObject("MSXML.XMLHTTPRequest") '//если ошибка используем другой объект для запроса
On Error GoTo 0
If oHttp Is Nothing Then Exit Function '//если не смогли создать объект для запроса, тогда выходим из функции
Call oHttp.Open("GET", query, False) 'открываем объект для запроса
oHttp.Send '//отправляем запрос на сервер (сайт)
otvet = UCase(oHttp.responseText) '//полученные ответ запроса преобразуем в верхний регистр, для дальнейшего парсинга
'//парсим строку ответа для получения значения курса валюты
rate = CCur(Mid(otvet, InStr(InStr(1, otvet, txtCurr), otvet, "</TD></TR>") - 7, 7)) '//парсим строку ответа
Set oHttp = Nothing '//закрываем объект запроса
KursCB = rate
End Function