Если Вам часто приходится в своих таблицах 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

Loading

9 комментариев

  3. может я чего-то не понимаю, но помоему проще брать данные из 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")

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

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

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

Добавить комментарий

This site uses Akismet to reduce spam. Learn how your comment data is processed.