Макрос (функция) для получения курса валют с сайта ЦБ РФ

Данный код (пользовательская функция) позволяет получить данные о курсе валюты с сайта Центробанка.

Данную функцию можно использовать и в виде формулы на листе Excel (см. пример во вложении)

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

Sub ПримерИспользованияФункции_GetRate()
    MsgBox "Сегодня курс доллара к рублю составил " & GetRate("USD", Now), vbInformation
    MsgBox "А вчера курс евро к рублю был равен " & GetRate("EUR", Now - 1), vbInformation
End Sub

Поддерживается получение курсов рубля по отношению к следующим валютам:

AUD               Австралийский доллар
AZN               Азербайджанский манат
GBP               Фунт стерлингов Соединенного королевства
AMD               Армянский драм
BYR               Белорусский рубль
BGN               Болгарский лев
BRL               Бразильский реал
HUF               Венгерский форинт
DKK               Датская крона
USD               Доллар США
EUR               Евро
INR               Индийская рупия
KZT               Казахский тенге
CAD               Канадский доллар
KGS               Киргизский сом
CNY               Китайский юань
LVL               Латвийский лат
LTL               Литовский лит
MDL               Молдавский лей
NOK               Норвежская крона
PLN               Польский злотый
RON               Новый румынский лей
XDR               СДР (специальные права заимствования)
SGD               Сингапурский доллар
TJS               Таджикский сомони
TRY               Турецкая лира
TMT               Новый туркменский манат
UZS               Узбекский сум
UAH               Украинская гривна
CZK               Чешская крона
SEK               Шведская крона
CHF               Швейцарский франк
EEK               Эстонская крона
ZAR               Южноафриканский рэнд
KRW               Вон Республики Корея
JPY               Японская иена

Если вы желаете вывести информацию по всем валютам - используйте макрос ВывестиСегодняшниеКурсыВсехВалют:

Sub ВывестиСегодняшниеКурсыВсехВалют()
    On Error Resume Next
    Set xmldoc = CreateObject("Msxml.DOMDocument"): xmldoc.async = False
    url_request = "http://www.cbr.ru/scripts/XML_daily.asp?date_req=" + Format(Now, "dd\/mm\/yyyy")
    If xmldoc.Load(url_request) <> True Then Exit Sub
    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)
        Debug.Print "Курс " & xmlNode.childNodes(1).Text & " (установлен " & strDate & "): " & _
                    xmlNode.childNodes(4).Text & " рублей за " & xmlNode.childNodes(2).Text & _
                  " " & xmlNode.childNodes(3).Text
    Next
End Sub

Результат работы макроса ВывестиСегодняшниеКурсыВсехВалют:

Курс AUD (установлен 28/07/2010): 27,2968 рублей за 1 Австралийский доллар
Курс AZN (установлен 28/07/2010): 37,6342 рублей за 1 Азербайджанский манат
Курс BRL (установлен 28/07/2010): 17,1589 рублей за 1 Бразильский реал
...
Курс HUF (установлен 28/07/2010): 13,7407 рублей за 100 Венгерских форинтов
Курс DKK (установлен 28/07/2010): 52,7135 рублей за 10 Датских крон
Курс USD (установлен 28/07/2010): 30,2391 рублей за 1 Доллар США
Курс EUR (установлен 28/07/2010): 39,3139 рублей за 1 Евро
...
Курс CHF (установлен 28/07/2010): 28,6953 рублей за 1 Швейцарский франк
Курс EEK (установлен 28/07/2010): 25,1057 рублей за 10 Эстонских крон
Курс ZAR (установлен 28/07/2010): 41,1383 рублей за 10 Южноафриканских рэндов
Курс KRW (установлен 28/07/2010): 25,6003 рублей за 1000 Вон Республики Корея

Вложения:

Комментарии

Настройки просмотра комментариев

Выберите нужный метод показа комментариев и нажмите "Сохранить установки".

Благодарю сердечно. Очень актуальная своевременная разработка

Здравствуйте, Павел
Все мои макросы написаны под Windows.
На Маке делается всё иначе (касательно загрузки страниц из интернета), и переделать я не смогу (и потому что не знаю как, и потому что протестировать мне не на чем)

Добрый день!
Макрос не работает на Mac почему-то.
В ячейках, где должны быть курсы, просто стоят нули.
Может можно как-то подправить под Mac?

Да, можно. Можем сделать под заказ.

Добрый день! Обнаружил, что функция по разному отрабатывает в зависимости от региональных настроек установленных на компьютере. Работаю с настройками United States. Такое ощущение, что функция по разному обрабатывает знак разделителя дробной части. В русских настройках это запятая, а в американских точка. Можно это поправить как-то?

Используется в виде надстройки курсы.xlam. формула =GetRate(P2;N3) в одной ячейке (в двух ячейках для двух валют). в третьей ячейке формула =СЕГОДНЯ(). Речь идет о работе на удаленном рабочем столе в корпоративной сети. Надстройка включена на двух компах

Видимо, вы используете этот код не как макрос, а как формулы в ячейках Excel (причем, еще и протянули эту формулу на много строк)
И для каждой ячейки Excel выполняется отдельный запрос курса, оттого и тормозит
Надо в одной ячейке формулу написать. А из других ячеек просто ссылаться на ячейку с формулой.
Тогда запрос к сайту будет выполняться только один раз, и тормозить не будет

Поставил данный макрос и всё работает нормально. Но почему-то через какое-то время (дня 2-3) он начинает сильно грузить эксель. Формулы считаются с задержкой, при внесении данных в ячейки в строке состояния появляется сообщение "Расчёт 4 процессор(ы) 98%" или любая другая цифра процентов. А периодически эксель вообще подвисает до состояния "не отвечает". Иногда за день такое бывает пару раз, иногда прям чуть ли не по часу виснет и тормозит. Удаляешь макрос из файла - эксель просто летает.
Помогите, пожалуйста, сам не могу понять, почему такое может быть?

Поставил данный макрос и всё работает нормально. Но почему-то через какое-то время (дня 2-3) он начинает сильно грузить эксель. Формулы считаются с задержкой, при внесении данных в ячейки в строке состояния появляется сообщение "Расчёт 4 процессор(ы) 98%" или любая другая цифра процентов. А периодически эксель вообще подвисает до состояния "не отвечает". Иногда за день такое бывает пару раз, иногда прям чуть ли не по часу виснет и тормозит. Удаляешь макрос из файла - эксель просто летает.
Помогите, пожалуйста, сам не могу понять, почему такое может быть?

Эля, можем сделать под заказ.
По цене - от 1000 руб (если готовы оплатить - пишите в скайп или на почту)

Добрый день.
Помогите пожалуйста преобразовать данный макрос для сайта ЕЦБ, интересует как правило отношение EUR к USD.
https://www.ecb.europa.eu/stats/policy_and_exchange_rates/euro_reference...
Большое спасибо!!!! :*

Здравствуйте, Влад
Минимальная стоимость заказа у меня, - 1500 руб
Если устраивает - пишите в скайп, сделаю

Добрый день, сколько будет стоить сделать парсер, для вывода на сайт онлайн курса на золото и серебро в EUR за 1 гр.?
С сайта:
https://www.goldbroker.com/charts/gold-price/eur
https://www.goldbroker.com/charts/silver-price/eur

Ваш код не работает, потому что он не универсальный, - сайт поменялся, и код ищет курс не в том месте страницы.
Могу переделать функцию под заказ (если готовы оплатить)

Добрый день!
Может мне кто-нибудь помочь, посмотреть, почему не работает код?
Function КурсНБРБ(Optional ТипВалюты As String, Optional ByVal Дата As String) As Double

Application.Volatile True
Dim sRequest As String, sReqRes As String, sRes As String
Dim sDay As String, sMonth As String, sYear As String
Dim lPos As Long, lLastPos As Long, lDel As Long, oHttp
If IsMissing(ТипВалюты) Or ТипВалюты = "" Then ТипВалюты = "EUR"
If IsMissing(Дата) Or Дата = "" Then Дата = Now
If Not IsDate(Дата) Then Дата = CDate(Дата)
sDay = Format(Дата, "dd"): sMonth = Format(Дата, "mm"): sYear = Format(Дата, "yyyy")
sRequest = "http://www.nbrb.by/Services/XmlExRates.aspx C_month=" & sMonth & "&C_year=" & sYear & "&date_req=" & sDay & "%2F" & _
sMonth & "%2F" & sYear
On Error Resume Next
Set oHttp = CreateObject("MSXML2.XMLHTTP")
If Err <> 0 Then
Set oHttp = CreateObject("MSXML.XMLHTTPRequest")
End If
If oHttp Is Nothing Then Exit Function
oHttp.Open "GET", sRequest, False
oHttp.Send
sReqRes = oHttp.responseText
lPos = InStr(1, sReqRes, UCase(ТипВалюты), 1)
lPos = InStr(lPos, sReqRes, "", 1) + 4
lLastPos = InStr(lPos, sReqRes, "", 1)
lDel = Mid(sReqRes, lPos, lLastPos - lPos)
lPos = lLastPos + 10
lPos = InStr(lPos, sReqRes, "", 1) + 4
lLastPos = InStr(lPos, sReqRes, "", 1) - 7
sRes = Mid(sReqRes, lPos, 7)
sRes = sRes / lDel
Set oHttp = Nothing
sRes = Replace(sRes, ",", Mid(1 / 2, 2, 1))
КурсНБРБ = sRes
End Function

Здравствуйте Игорь возможно ли эту функцию подогнать под этого сайта http://nbt.tj/tj/kurs/kurs.php и как сделать Спасибо

Игорь, огромное Вам спасибо.
Все прекрасно работает, попробовал пока вставить USD в прайс.
По примерам все легко и просто, первый раз делал такое.
Буду почитывать Ваш сайт :)

Здравствуйте! Подскажите, кто знает, как написать макрос для "вытягивания" курса драгоценных металлов с сайта ЦБ РФ, например для золота. Вот, что у меня получилось, но не работает.
Sub GetZoloto()
Dim xmldoc, nodeList
On Error Resume Next
Set xmldoc = CreateObject("Msxml.DOMDocument"): xmldoc.async = False
'пример URL http://www.cbr.ru/scripts/xml_metall.asp?date_req1=14/02/2016&date_req2=...
If Not xmldoc.Load("http://www.cbr.ru/scripts/xml_metall.asp?date_req1=" & _
Format(InputBox("Введите начальную дату поиска в формате ДД.ММ.ГГГГ", "Курс Золота", Date), "dd\/mm\/yyyy") & _
"&date_req2=" & _
Format(InputBox("Введите конечную дату поиска в формате ДД.ММ.ГГГГ", "Курс Золота", Date), "dd\/mm\/yyyy")) Then Exit Sub
Set nodeList = xmldoc.SelectNodes("//Record[@Code='1']")
If nodeList.Length Then ActiveCell.Value = CDbl(nodeList.Item(0).ChildNodes(4).Text)
End Sub
И второй вопрос, как в этом макросе сделать MsgBox с выводом получившегося URL для проверки?
Спасибо всем, за любой ответ.

Нет, на сайте всё также.
Видимо, у вас в Windows (или в Excel) установлен другой десятичный разделитель.

В примере есть макрос Пример_Использования Функции_GetRate
Запустив его, вы увидите, что выводится корректное значение курса.
И формулы в примере возвращают корректное значение курса.

Курс евро на 1/31/2016 вытаскивает как 819077 (т.е. надо поделить на 10 000). Видимо указатель делителя на сайте цб изменился?

Здравствуйте, Марк.
Чтобы пересчитать все формулы на листе Excel - надо нажать кнопку F9

написать макрос для пересчета вы сможете, если не будете лениться, и поищете в интернете, что такое макросы, и куда их вставлять.
макрос будет из одной строки: (вставить код надо в модуль ЭтаКнига)

Private Sub Workbook_Open() ' при открытии книги Excel - автоматический пересчет формул
    ActiveSheet.UsedRange.Formula = ActiveSheet.UsedRange.Formula
End Sub

под нацбанк украины - много раз люди писали макросы. осталось только поискать в гугле готовое решение...

Очень нужен данный макрос GetRate для работы :)
Но, заметил, что данные курса (в частности используються валюты доллар и гривна) не обновляються постоянно). Как можно доработать этот макрос, чтобы все данные курсов обновлялись как при "Получении внешних данных" либо при открытии файла, либо принудительно с заданным интервалом времени. А еще лучше оба варианта. Обновление до актуального курса происходит только при нажатии на ячейке клавиш F2 и Enter.
PS В VBA - полный ноль, так что сам это реализовать/написать не смогу. Поэтому прошу помощи у знающих :)
PPS А еще если бы кто-то адаптировал так же данный макрос по Нацбанк Украины, но я знаю что у них нет своего API для прямого парсинга курсов...

Спасибо за информацию! а тем кто пытается умничать - пусть идут лесом

Усовершенствовать можно (брать любые данные с любого сайта)
Но, доработка бесплатных макросов, - только под заказ (не бесплатно)
Если готовы заплатить, - пишите на почту, что с какого сайта нужно взять.

Скажу больше, курс банка, что отображается в яндексе, это чисто информативно, он нам не полезен в жизни. Нам интересен курс продажи и покупки, а он отличается, именно с этими цифрами нам приходиться иметь дело. Я товар закупаю за доллары и продаю за рубли, соответственно мне доллары надо купить. Курс банка получается не интересен, новости я так смотрю.
Просим автора усовершенствовать фукцию

заглавная яндекса http://www.yandex.ru/
После 11-30 выкладывают курс на завтра. Отоброжается 2 курса (текущий и курс на момент конца торгов, т.е. завтрашний):
сегодня завтра
USD ЦБ 47,0294 −0,3247 46,7047
До 11-30 отображается только текущий.
Дело в следующем: когда видно что курс на момент торгов сильно превышает текущий, продажи импортного товара обычно уже ведутся по завтрашнему курсу. А ваша формула позволяет подставлять автоматически значения только текущего курса.

А с какой страницы какого сайта (по какой ссылке) брать этот курс?

Сейчас крайне актуален не курс на сегоднящний день, а курс на момент окончания торгов (Яндекс выкладывает его как курс на завтрашний день в 11:30). Не подскажете как взять его с сайта ЦБ РФ? Что изменить в макросе и функции?

В ячейку с датой напишите для проверки формулу =СЕГОДНЯ()
тогда точно дата будет в нужном формате

Выдаёт 0
Загрузил макрос. В поле вписал код валюты и дату. Может дату как текст надо вписывать ?

Да неужели... у всех работает, а у вас нет.
Дело явно не в макросе. На другом компе проверьте

НЕ РАБОТАЕТ

Игорь, если выбросить лишнее, то для USD можно сделать функцию:
Function GetUSD(Optional ByVal MyDate As Date) As Double
Dim xmldoc, nodeList
If MyDate = 0 Then MyDate = Date
On Error Resume Next
Set xmldoc = CreateObject("Msxml.DOMDocument"): xmldoc.async = False
If Not xmldoc.Load("http://www.cbr.ru/scripts/XML_daily.asp?date_req=" & Format(MyDate, "dd\/mm\/yyyy")) Then Exit Function
Set nodeList = xmldoc.SelectNodes("//Valute[@ID='R01235']")
If nodeList.Length Then GetUSD = CDbl(nodeList.Item(0).ChildNodes(4).Text)
End Function

Здравствуйте, Михаил
Этот код писал не я (просто взял где-то готовый, и сделал его в виде функции)
Там много лишнего в коде, - можно половину выкинуть.

В коде функции, на мой взгляд, лишние две строчки:
Set nodeList = xmldoc.selectNodes("ValCurs"): Set xmlNode = nodeList.Item(0).CloneNode(True)
Set node_attr = xmlNode.Attributes(0): strDate = node_attr.Value
Зачем они? node_attr ни где не используется да и strDate тоже

Не могли бы вы подсказат почему моя функция работает хорошо, когда я применяю её к одной ячейке, но когда я пытаюсь применить эту функцию для нескольких ячеек одновременно, она возвращает "0" для некоторых ячеек.

Function GetRate(ByVal CurrencyName As String, ByVal RateDate As Date) As Double
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://cbar.az/currencies/" & Format(RateDate, "dd\.mm\.yyyy") & ".xml"

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("*/ValType/Valute")
For i = 0 To nodeList.Length - 1
Set xmlNode = nodeList.Item(i).CloneNode(True)
If nodeList.Item(i).Attributes.getNamedItem("Code").Text = CurrencyName Then
CurrencyRate1 = (xmlNode.ChildNodes(2).Text)
CurrencyRate = CDbl(Replace(CurrencyRate1, ".", Application.International(xlDecimalSeparator)))
divisor = Val(xmlNode.ChildNodes(0).Text)
GetRate = CurrencyRate / divisor
Exit Function
End If
Next
End Function

Сегодня (13.06.13) перестал корректно работать макрос. Вместо курсов по некоторым валютам и датам отображает нули, причем скачал пример из этого поста, там тоже самое..

To:
#5Гость, 15 Апр 2013 - 12:12.
мне кажется что не работает на USD , всегда показываешь 7,993 .как исправить ?
а так вообще супер просто .

Усьо работает, просто курс 7.993 долго держится... возьми, например, дату год назад...

Мало ли что там не работает... есть много сайтов, где выложены нерабочие макросы.
Я отвечаю только за свои макросы, опубликованные у меня на сайте.

Если вам нужен работающий макрос под НБУ, - могу сделать (не бесплатно)

Я это комментировал , что не работает USD с НБУ.
> Есть готовая UDF функция для импорта курсов валют с сайта НБУ

Ну как это не работает... есть же пример использования функции:

курс доллара к рублю в Excel

Как видите, показывает точный сегодняшний курс доллара с сайта центробанка.

Заметил интересную особенность. Иногда отображает курс ЕВРО (на остальных не проверял) на будущую дату

Дата: 06.05.2013 - Курс ЕВРО: 40,5132
Дата: 09.05.2013 - Курс ЕВРО: 40,5132

,а иногда - нет

Дата: 18.05.2013 - Курс ЕВРО: 0,0000
Дата: 20.05.2013 - Курс ЕВРО: 0,0000

Но, видимо, это недочет со стороны сайта cbr.ru.

мне кажется что не работает на USD , всегда показываешь 7,993 .как исправить ?
а так вообще супер просто .

Есть готовая UDF функция для иморта курсов валют с сайта НБУ. Посмотри здесь:
http://moonexcel.ho.ua/index.php?page=tip_kursNBU_ua

EducatedFool, спасибо за совет. Поменял - все заработало.

Здравствуйте, lexabor.

Да, есть такая проблема, - когда писал макрос, не обратил на это внимания.
Чтобы избежать ошибки, надо заменить строку кода

Function GetRate(ByVal CurrencyName As String, ByVal RateDate As Date) As Single

на строку
Function GetRate(ByVal CurrencyName As String, ByVal RateDate As Date) As Double

(короче, поменять Single на Double)

Судя по всему, при ошибка появляется при конвертации из Single на Double
Если же произвести указанную замену в коде, проблема исчезнет.

Добрый день, EducatedFool,

У меня вопрос по поводу точности Вашего макроса - почему-то не всегда корректно значение четвертого знака после запятой? Ведь, насколько я понял, запрос к серверу ЦБР возвращает значения с четырьмя знаками после запятой.

Комментарий Сумма (Евро) Дата Курс Евро на заданную дату Сумма (Рубли)
По данным с сайта cbr.ru 10000 27.12.2012 40,3659000 403659,00
По данным из Вашего макроса 10000 27.12.2012 40,3658981 403658,98

Если обернуть Ваш макрос в функцию округления с числом разрядов равным 4 (=ОКРУГЛ(GetRate("EUR";"Дата");4)), то результат получается корректный. Можно ли как-нибудь решить эту проблему в макросе?

Да, можно и с нац. банка взять данные, и из большинства других банков.

Если самостоятельно не справитесь с адаптацией кода под другой банк - оформляйте заказ на сайте, сделаю (не бесплатно)

а с нац банка можно вытаскивать данные ? по гривнам

Чтобы было понятно, как именно не работает данная функция опишу как все происходит у меня в excel. Как только Excel пытается "вылезти" в инет, то выскакивает окошко, с просьбой ввести логин и пароль для доступа в инет по учетной записи, я ввожу, нажимаю "ок" и все нормально, любые функции и макросы, которым нужен доступ в инет работают, как, например, вот этот макрос http://www.planetaexcel.ru/tip.php?aid=91 - получение курса доллара с сайта ЦБ РФ. А при выполнении Вашей функции окошко с запросом логина и пароля не выскакивает и соответственно в качестве результата у меня нули. Честно говоря, я в VBA вообще не силен, может быть, выше приведенный макрос (по ссылке) подскажет вам возможное решение возникшей у меня проблемы?

Отправить комментарий

Содержание этого поля является приватным и не предназначено к показу.
CAPTCHA
Подтвердите, пожалуйста, что вы - человек:
  _   _   _   _       _____          _____ 
| \ | | | | | |__ | ____| ___ | ___|
| \| | | | | '_ \ | _| / _ \ | |_
| |\ | | | | |_) | | |___ | __/ | _|
|_| \_| |_| |_.__/ |_____| \___| |_|
Введите код, изображенный в стиле ASCII-арт.

Не получается применить макрос? Не удаётся изменить код под свои нужды?

Оформите заказ у нас на сайте, не забыв прикрепить примеры файлов, и описать, что и как должно работать.