Lost your password?


Хитрости »
Основные понятия (27)
Сводные таблицы и анализ данных (10)
Графики и диаграммы (5)
Работа с VB проектом (12)
Power BI и Power Query (23)
Условное форматирование (5)
Списки и диапазоны (5)
Макросы(VBA процедуры) (68)
Разное (43)
Баги и глюки Excel (5)

Получить курс валют от ЦБР

Если Вам часто приходится в своих таблицах Excel использовать текущий курс валют - эта статья для вас. Приведенная ниже функция пользователя позволяет получить курс валюты на заданную дату.

'---------------------------------------------------------------------------------------
' Procedure : КурсЦБР
' DateTime  : 15.09.2013 23:11
' Author    : The_Prist(Щербаков Дмитрий)
'             http://www.excel-vba.ru
' Purpose   : http://www.excel-vba.ru/chto-umeet-excel/poluchit-kurs-valyut-ot-sberbanka/
'---------------------------------------------------------------------------------------
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 ТипВалюты = "USD"
    If IsMissing(Дата) Or Дата = "" Then Дата = Now
    If Not IsDate(Дата) Then Дата = CDate(Дата)
 
    sDay = Format(Дата, "dd"): sMonth = Format(Дата, "mm"): sYear = Format(Дата, "yyyy")
    sRequest = "http://cbr.ru/currency_base/daily.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 = Replace(oHttp.responseText, vbNewLine, "")
    sReqRes = Replace(sReqRes, Chr(10), "")
    sReqRes = Replace(sReqRes, " ", "")
    lPos = InStr(1, sReqRes, UCase(ТипВалюты) & "</td>", 1)
    lPos = InStr(lPos, sReqRes, "<td>", 1) + 4
    lLastPos = InStr(lPos, sReqRes, "</td>", 1)
    lDel = Mid(sReqRes, lPos, lLastPos - lPos)
    lPos = InStr(lLastPos + 10, sReqRes, "<td>", 1) + 4
    lLastPos = InStr(lPos, sReqRes, "</td>", 1) - 4
    sRes = Mid(sReqRes, lPos, 7)
    sRes = sRes / lDel
    Set oHttp = Nothing
    sRes = Replace(sRes, ",", Mid(1 / 2, 2, 1))
    КурсЦБР = sRes
End Function

Синтаксис функции:
=КурсЦБР(A1;B1)
=КурсЦБР("EUR";"12.09.2013")
=КурсЦБР("EUR")
=КурсЦБР()

ТипВалюты(A1) - Необязательный аргумент. Ссылка на ячейку или текстовое обозначение валюты. Если не указан - возвращает курс доллара. Некоторые из доступных валют:

  • AUD - Автралийский доллар(Australian Dollar)
  • BYR - Беларусский рубль(Belarusian Rouble)
  • DKK - Датская крона(Danish Krones)
  • USD - Американский доллар(United States Dollar)
  • EUR - ЕВРО(European Monetary Unit)
  • ISK - Исландская крона(Icelandic Krona)
  • KZT - Казхстанский тенге(Kazakhstan Tenge)
  • CAD - Канадский доллар(Canadian Dollar)
  • CNY - Китайский Ренминби Юаня(Chinese Yuan Renminbi)
  • TRY - Турецкая Новая Лира(Turkish New Lira)
  • NOK - Норвежская Крона(Norwegian Krone)
  • XDR - СДР - Специальные права заимствования(Special Drawing Right)
  • SGD - Сингапурский Доллар(Singapore Dollar)
  • UAH - Украинская гривна(Ukrainian Hryvnia)
  • GBP - Фунт Стерлингов Объединенного Королевства(United Kingdom Pound Sterling)
  • SEK - Шведская Крона(Swedish Krona)
  • CHF - Швейцарский Франк(Swiss Franc)
  • JPY - Японская Иена(Japanese Yen)

Дата(B1) - необязательный аргумент. Ссылка на ячейку с датой либо непосредственно дата. Если не указан, то используется текущая дата.


И реализация чуть проще от пользователя krosav4ig - через встроенный парсер XML:

'---------------------------------------------------------------------------------------
' Procedure : ЦБР
' DateTime  : 09.10.2014
' Author    : krosav4ig
' Purpose   : http://www.excel-vba.ru/chto-umeet-excel/poluchit-kurs-valyut-ot-sberbanka/
'---------------------------------------------------------------------------------------
Function ЦБР(Optional ТипВалюты$, Optional Дата As Date) As Double
    Dim xmDoc As Object, date_req$
    Set xmDoc = CreateObject("msxml2.DOMDocument")
    If Not CBool(Len(ТипВалюты)) Then ТипВалюты = "USD"
    date_req = "?date_req=" & IIf(Дата, Дата, Date)
    xmDoc.async = 0: xmDoc.Load ("http://www.cbr.ru/scripts/XML_daily.asp" & date_req)
    With xmDoc.SelectSingleNode("*/Valute[CharCode='" & UCase(ТипВалюты) & "']")
        ЦБР = CDbl(.ChildNodes(4).Text) / Val(.ChildNodes(2).Text)
    End With
    Set xmDoc = Nothing
End Function

Аргументы и методы их указания полностью идентичны аргументам в первом варианте функции:
ТипВалюты(A1) - Необязательный аргумент. Ссылка на ячейку или текстовое обозначение валюты. Если не указан - возвращает курс доллара.
Дата(B1) - необязательный аргумент. Ссылка на ячейку с датой либо непосредственно дата. Если не указан, то используется текущая дата.

Так же см.:
Курс валют при помощи Power Query
Перевод текста в ячейках через Google


Статья помогла? Поделись ссылкой с друзьями!
  Плейлист   Видеоуроки

Поиск по меткам

Access apple watch Multex Power Query и Power BI VBA управление кодами Бесплатные надстройки Дата и время Записки ИП Надстройки Печать Политика Конфиденциальности Почта Программы Работа с приложениями Разработка приложений Росстат Тренинги и вебинары Финансовые Форматирование Функции Excel акции MulTEx ссылки статистика
Обсуждение: 9 комментариев
  1. Есть проблема - тип валюты показывает всегда верхнюю строку AUD Автралийский доллар(Australian Dollar)

  2. Олег, спасибо. Исправил код.

  3. krosav4ig:

    может я чего-то не понимаю, но помоему проще брать данные из xml, чем парсить thml
    Function ЦБР#(Optional Curr$, Optional dDate As Date) As Double
        Dim d As New DOMDocument, date_req$
        Set d = New DOMDocument
        If Not CBool(Len(Curr)) Then Curr = "USD"
        date_req = "?date_req=" & IIf(dDate, dDate, Date)
        d.async = 0: d.Load ("http://www.cbr.ru/scripts/XML_daily.asp" & date_req)
        With d.SelectSingleNode("*/Valute[CharCode='" & UCase(Curr) & "']")
            ЦБР = CDbl(.ChildNodes(4).Text) / Val(.ChildNodes(2).Text)
        End With
        Set d = Nothing
    End Function

    синтаксис
    =ЦБР()
    =ЦБР(;"1 1 14")
    =ЦБР("aud")
    =ЦБР("eur";"1-1-2014")
    =ЦБР("cad";"1.1.14")
    =ЦБР("cad";"1,1,2014")
    =ЦБР("jpy";"1/1/14")

  4. krosav4ig:

    немного ошибся, в 1 строке кода лишнее as double, и еще забыл, =ЦБР(;"1 января 2014") тоже работает

  5. krosav4ig, согласен. Даже уже видел такую реализацию, но обновить статью дополнив кодом руки пока не доходят. В ближайшее время дополню кодом с чтением схемы XML через встроенную библиотеку.
    В Вашем коде лучше использовать позднее связывание, дабы не заставлять пользователей подключать из VBA нужную библиотеку.

  6. гость:

    Что то не понятно вообще. А где сама процедура запроса?
    d.Load тут маловато. USD вообще не является указателем на курс .

    • гость, вообще-то load достаточно. Если не умеете работать с XML библиотекой - не надо пытаться делать выводы по работе функций. Функция работает как положено. И указатель на USD работает на ура. Потрудились бы сначала проверить и понять, прежде чем писать комментарий...

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

      Function ЦБР#(Optional Curr$, Optional dDate As Date)
          Dim d As Object, date_req$
          Set d = CreateObject("msxml2.DOMDocument")
          If Not CBool(Len(Curr)) Then Curr = "USD"
          date_req = "?date_req=" & IIf(dDate, dDate, Date)
          d.async = 0: d.Load ("http://www.cbr.ru/scripts/XML_daily.asp" & date_req)
          With d.SelectSingleNode("*/Valute[CharCode='" & UCase(Curr) & "']")
              ЦБР = CDbl(.ChildNodes(4).Text) / Val(.ChildNodes(2).Text)
          End With
          Set d = Nothing
      End Function
  7. Taga:

    У меня такая проблема - при использовании второго варианта макроса (через XML) сначала всё работало хорошо, а вот потом, где-то через неделю эксель начал сильно тупить, долго думать при простом вводе значений в любую ячейку и периодически вообще зависать секунд на 10-15. Ещё где-то через неделю он начались краши при попытках переименовать лист. После удаления макроса всё стало работать идеально. В чём может быть проблема? Т.к. макрос очень удобен, я им подгружаю курсы ЦБ на следующий день.
    Буду очень благодарен за помощь.

  8. Azamateus:

    На сегодня, чтобы работало, строки с присвоением значения переменной sRequest нужно заменить на:
    sRequest = "http://cbr.ru/currency_base/daily/?UniDbQuery.Posted=True&UniDbQuery.To=" & Format(Äàòà, "dd.mm.yyyy")

Поделитесь своим мнением

Комментарии, не имеющие отношения к комментируемой статье, могут быть удалены без уведомления и объяснения причин. Если есть вопрос по личной проблеме - добро пожаловать на Форум


Для оформления сообщений Вы можете использовать следующие тэги:
<a href="" title=""> <abbr title=""> <acronym title=""> <b> <blockquote cite=""> <cite> <code> <del datetime=""> <em> <i> <q cite=""> <s> <strike> <strong>

Тренинги

Заказать
Юридическая информация

Использование материалов сайта

Политика Конфиденциальности

ИП Щербаков Дмитрий Валентинович
ОГРНИП: 318502700083307
ИНН: 504013350772

Наши партнеры

Перейти

Счетчики

Рейтинг@Mail.ru Яндекс.Метрика
© 2024 Excel для всех   Войти