Курс доллара для любой заданной даты

100871 07.10.2012 Скачать пример

Самые популярные в России курсы - это курсы валют.
Правда, на них мало учат, зато много наказывают.

Если Вам часто приходится узнавать курс доллара для определенной заданной даты в прошлом (даты заказа или поставки, например), то этот макрос сэкономит вам много времени. Вместо похода в архивы ЦБР достаточно будет его запустить.

Откройте редактор Visual Basic, нажав ALT+F11 или выбрав в меню Сервис - Макрос - Редактор Visual Basic (Tools - Macro - Visual Basic Editor), вставьте новый модуль (меню Insert - Module) и скопируйте туда текст этого макроса:

SSub GetDollar()
    'объявляем переменные
    Dim sURI As String
    Dim oHttp As Object
    Dim htmlcode, outstr As String
    Dim inpdate As Date
    Dim d, m, y As Integer
    
    'выводим диалоговое окно с вопросом о дате
    inpdate = CDate(InputBox("Введите дату в формате ДД.ММ.ГГГГ", _
        "Курс доллара", Date))
    
    'разбираем дату на составляющие
    d = Format(inpdate, "dd")
    m = Format(inpdate, "mm")
    y = Format(inpdate, "yyyy")
    'формируем строку для веб-запроса
    sURI = "http://cbr.ru/currency_base/daily.aspx?C_month=" & m & "&C_year=" _
                  & y & "&date_req=" & d & "%2F" & m & "%2F" & y
    'делаем запрос
    On Error Resume Next
    Set oHttp = CreateObject("MSXML2.XMLHTTP")
    If Err.Number <> 0 Then
        Set oHttp = CreateObject("MSXML.XMLHTTPRequest")
    End If
    On Error GoTo 0
    If oHttp Is Nothing Then
        Exit Sub
    End If
    oHttp.Open "GET", sURI, False
    oHttp.Send
    'получаем HTML страницы с курсами и извлекаем из него курс доллара
    htmlcode = oHttp.responseText
    outstr = Mid(htmlcode, InStr(InStr(1, htmlcode, "USD"), htmlcode, "") - 18, 7)
    Set oHttp = Nothing
    'заменяем точку на запятую и выводим в активную ячейку
    outstr = Replace(outstr, ",", ".")
    ActiveCell.Value = outstr
End Sub

Теперь, если закрыть редактор Visual Basic и вернуться в Excel, то через меню Сервис - Макрос - Макросы, или нажав ALT+F8, можно запустить наш макрос GetDollar, ввести в появившееся окно дату и получить курс доллара для заданной даты в текущей ячейке. Для удобства запуска можно сделать кнопку макроса на панели инструментов или на листе или назначить макросу сочетание клавиш.

Фактически, макрос загружает данные из архива сайта Центробанка РФ, поэтому для вставки курса в текущую ячейку необходимо иметь доступ в интернет (в данный момент). Данные вставляются как константы (без связи и обновления).

Для получения курса евро, иены, фунта и других валют необходимо сделать следующее:

  1. Открываете страницу сайта ЦБ со списком валют, обновляемых ежедневно за любую дату, например http://cbr.ru/currency_base/daily.aspx?C_month=10&C_year=2012&date_req=01.10.2012
  2. Открываем исходный HTML-код запрошенной страницы (правой кнопкой по веб-странице - команда Просмотр HTML-кода в IE или что-то похожее в других браузерах)  и ищем обозначение необходимой валюты, например USD.
  3. Считаем на сколько символов в исходнике от аббревиатуры валюты отстоит требуемый курс. Например, для доллара это 85, то есть с 85-го символа начинается числовое значение самого курса. Для евро = 81, для фунта = 96, для иены = 89, для швейцарского франка = 87 и т.д.
  4. Вставляем получившееся число и код валюты в макрос в строку  outstr = Mid(htmlcode, InStr(1, htmlcode, "USD") + 87, 7)

Ссылки по теме

 



Эльмира
07.10.2012 16:47:50
Здравствуйте.
Давно пользуюсь этим замечательным макросом для разных нужд.
Но вот возникла потребность, чтобы молча загружались нужные курсы на сегодня, без окна запроса.
Можно это как-то реализовать?
AKSENOV 048
07.10.2012 16:48:24
Можно так:
1)удалите или закомментируйте строку "npdate = CDate(InputBox(......" ;
2)замените 3 строки ниже на эти
d = Format(Date, "dd")
m = Format(Date, "mm")
y = Format(Date, "yyyy").
Nick
07.10.2012 16:50:59
В первую очередь спасибо огромное Юрию, если бы не он......
Еще большое спасибо pashulka - который научил меня VBA
Ну и немного лепты внесу со своей стороны:

Sub GetCurrencyRateNBU_after_2012_01_04()

 ' программа обновления курсов с сайта НБУ
 ' обновляет только USD и UAH, тем кто хочет добавить иные валюты - просто скопируйте сегмент и 
 'переименуйте валюту
 ' переписана 04,01,2012 в связи с обновлением дизайна сайта НБУ
 ' собрана из запчастей взятых на просторах интернета.

 Dim sURI As String
 Dim oHttp As Object
 Dim HTMLcode As String

 Dim C As Range
 Dim Q As Long
 Dim iP As Long, z As Long
 Dim S As String, S1 As String, iOnlyTable As String
 Dim b As Object
 Dim massive(30, 5)
 Dim iDatas As Date

 iiDate = Cells(21, 2).Value
 sURI = "[URL=http://bank.gov.ua/control/uk/curmetal/currency/search?formType=searchFormDate&time_step=daily&date]http://bank.gov.ua/control/uk/curmetal/currency/search?formType=searchFormDate&time_step=daily&date[/URL]=" & iiDate
 On Error Resume Next
 Set oHttp = CreateObject("MSXML2.XMLHTTP")
 If Err.Number <> 0 Then
 Set oHttp = CreateObject("MSXML.XMLHTTPRequest")
 End If
 If oHttp Is Nothing Then Exit Sub 'вот здесь если вылетает, значит можно попытаться подключить библиотеки в Tools-References
 On Error GoTo ConnectionError
 oHttp.Open "GET", sURI, False
 On Error GoTo ConnectionError
 oHttp.send
 HTMLcode = oHttp.responseText
 iP = InStr(1, HTMLcode, "України<br/>встановлює")
 HTMLcode = Mid(HTMLcode, iP, 10000) 'обрезали оставив только диапазон который отвечает за название страницы и дату содержимого
 iP = InStr(1, HTMLcode, "<td class=") + 6 + 11
 iDatas = Mid(HTMLcode, iP, 10)
 iOnlyTable = Mid(HTMLcode, InStr(100, HTMLcode, "<table cellpadding="), InStr(1000, HTMLcode, "</table>") - InStr(100, HTMLcode, "<table cellpadding=") + 10)
 If MsgBox("Использовать данные НБУ за " & iDatas & " ?", vbYesNo Or vbQuestion Or vbDefaultButton1, Application.Name) = vbNo Then Exit Sub
 Set Doc = CreateObject("HTMLFile")
 Doc.Write iOnlyTable ' я лентяй и не собираюсь парсить текст: делаем из куска кода таблицу на тегах
 Set b = Doc.all.tags("TABLE") ' даём понять, что нам нужна таблица (хотя кроме неё там ничего нет)
 indikatorProhoda = 0
 For Each uTableElement In b
 iRows = uTableElement.Rows.Length 'здесь получаю кол-во строк
 iCells = uTableElement.Cells.Length 'здесь получаю кол-во ячеек
 If (iCells / iRows) <> 5 Or ((iCells Mod iRows) <> 0) Then 'здесь проверяю таблицу на размерность - 5 колонок и нет объединений
 MsgBox "Table size is changed"
 GoTo vilet
 End If

 For j = 5 To uTableElement.Cells.Length - 1 ' побежали по ячейкам
 indCol = (((j - 1) Mod 5) + 1)
 indRow = (j \ 5)
 'Cells(indRow + 1, indCol) = uTableElement.Cells(j).innerHTML ' для наглядности в ячейки
 massive(indRow, indCol) = uTableElement.Cells(j).innerHTML ' в переменную
 indikatorProhoda = 1 ' убеждаемся в том, что массив наполнялся
 Next j

 vilet:
 Next uTableElement
 If indikatorProhoda = 0 Then
 MsgBox "перезапустите программу с правильной датой"
 Else
 For i = 1 To 29
 If massive(i, 1) = "USD" Then
 Cells(8, 4).Value = massive(i, 4) / massive(i, 2)
 indikatorProhoda = indikatorProhoda + 1
 End If
 If massive(i, 1) = "EUR" Then
 Cells(9, 4).Value = massive(i, 4) / massive(i, 2)
 indikatorProhoda = indikatorProhoda + 1
 End If
 Next i
 If indikatorProhoda = 3 Then
 Cells(7, 4).Values = Format(CDate(iDatas), "DD.MM.YYYY")
 MsgBox "Курсы обновлены" ', окно сейчас закроется
 Else
 MsgBox "Обновление прошло, только не успешно. Не все данные были найдены. Лезь в код."
 End If
 'Unload Me
 'FormForCurs.Hide
 Calculate
 End If

 NextForLoop:
 Set oHttp = Nothing
 Exit Sub
 ConnectionError:
 Call MsgBox("Ошибка связи с сервером НБУ", vbExclamation, Application.Name)
 End Sub
12.04.2014 14:27:28
Спасибо огромное! с помощью Вашего примера поняла как загружать данные с НБУ!!!
31.01.2013 16:55:17
Здравствуйте.
Поясните, может я что то не то делаю, скопировал текст макроса в редактор Visual Basic, закрыл его, захожу в MS Excel, нажимаю ALT+F8, появляется окно Макрос, ввожу имя GetDollar? меня выбрасывает обратно в VBA и появляется тот скопированный макрос, что не так? Все, спасибо, разобрался, оказывается порядковые номера убрать и наименование задать было)
MCH
29.08.2013 21:53:58
Николай, а почему Вы используете загрузку html сайта? Не проще ли получать данные через XML?
Примеры получения данных, используя XML с сайта ЦБР есть здесь: http://cbr.ru/scripts/Root.asp?Prtid=SXML

Как минимум существенная экономия трафика, если нужно загрузить множество котировок на разные даты, и скорость работы быстрее, с XML удобнее работать чем с текстом
30.08.2013 15:49:42
Да, я в курсе. Просто, когда этот пример писался (много лет назад), сайт ЦБ еще не умел XML отдавать. Поэтому приходилось парсить HTML :)
MCH
31.08.2013 04:29:05
с XML как то так:
Sub GetUSD()
    Dim xmldoc, nodeList
    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(InputBox("Введите дату в формате ДД.ММ.ГГГГ", "Курс доллара", Date), "dd\/mm\/yyyy")) Then Exit Sub
    Set nodeList = xmldoc.SelectNodes("//Valute[@ID='R01235']")
    If nodeList.Length Then ActiveCell.Value = CDbl(nodeList.Item(0).ChildNodes(4).Text)
End Sub
31.08.2013 07:56:45
Изящно :) Спасибо, думаю кому-то из читателей (да и мне тоже) точно пригодится!
08.10.2013 01:13:55
Погонял тесты, выяснилось, что такой способ почему-то медленнее на 20-30%, чем парсинг HTML из оригинального макроса в статье. Странно. Почему-то был уверен, что по вашему методу быстрее.
MCH
05.03.2014 06:33:32
Дизайн сайта CBR поменялся, поэтому макрос из статьи не работает, необходимо его править либо (что лучше) подгружать данные по XML, а то вдруг опять дизайн поменяется.

функция CBR() и макрос "Курсы ЦБ" из Plex используют  немного другой метод поиска курса валют, но также основываются на парсинге html  кода:
outstr = Mid(htmlcode, InStr(InStr(1, htmlcode, UCase(Money)), htmlcode, "</td></tr>") - 7, 7)

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

Думаю, лучше использовать загрузку курсов через XML, а не html.
Стандарт получения данных через XML не будут менять при очередной смене дизайна сайта.
06.03.2015 02:40:54
Подскажи пожалуйста, если валюта китайский юань и  бывает расчет как за 1 юань, так и за 10 юаней, как в макросе указать, что нужны данные только за 1 юань? В XML присутствует графа "Номинал". Полагаю, нужно разделить выводимое значение на этот номинал, а как это сделать не знаю...
<Item ID="R01375">

<Name>Китайский юань</Name>
<EngName>China Yuan</EngName>
<Nominal>10</Nominal>
<ParentCode>R01375</ParentCode>
MCH
06.03.2015 10:12:40
Функция для любой валюты, публикуемой на CBR
Function GetRate(ByVal CurrencyName As String, Optional ByVal RateDate As Date) As Double
    Dim i&, xmldoc, nodeList, xmlNode
    On Error Resume Next
    If Len(CurrencyName) <> 3 Then Exit Function Else CurrencyName = UCase(CurrencyName)
    If RateDate = 0 Then RateDate = Date
    Set xmldoc = CreateObject("Msxml.DOMDocument"): xmldoc.async = False
    If Not xmldoc.Load("http://www.cbr.ru/scripts/XML_daily.asp?date_req=" & Format(RateDate, "dd\/mm\/yyyy")) Then Exit Function
    Set nodeList = xmldoc.SelectNodes("//Valute")
    For i = 0 To nodeList.Length - 1
        Set xmlNode = nodeList.Item(i)
        If xmlNode.ChildNodes(1).Text = CurrencyName Then
            GetRate = CDbl(xmlNode.ChildNodes(4).Text) / Val(xmlNode.ChildNodes(2).Text)
            Exit Function
        End If
    Next i
End Function

Для юаней можно использовать:
=GetRate("CNY")
или
=GetRate("cny";"05.03.2015")
курс вычисляется на единицу валюты (а не на 10/100/1000)
16.05.2019 19:05:21
Спасибо от xls-чайника! не посоветуете как написать функцию, которая будет брать кросс курсы типа тех, что дает Гугл в запросе как ниже? я даже специально зарегистрировался на fixer.io....


https://www.google.com/search?q=usd+1000+in+eur&oq=USD+1000+in+EUR&aqs=chrome.0.0l4.5941j0j7&sourceid=chrome&ie=UTF-8
03.03.2014 10:22:05
Исправляем в  связи со сменой сайта ЦБ:
outstr = Mid(htmlcode, InStr(1, htmlcode, "USD") + 47, 7) для USD
outstr = Mid(htmlcode, InStr(1, htmlcode, "EUR") + 41, 7) для Евро
16.07.2014 12:14:40
Добрый день.

Никак не разберусь как прописатьв макрос  курс доллара к тенге с http://www.nationalbank.kz/?furl=cursFull&switch=rus

Подскажите пожалуйста.
19.03.2015 15:59:57
Всем доброго времени суток.
Сайт вне всяких похвал, многое почерпнул и использую, но так как уровень мой не высок некоторые вещи не получаются.
Попробовал сделать функцию по примеру MCH для курсов Национального банка Республики Беларусь, но опыта не хватило.
Может кто подскажет:
Function Курс_валюты(ByVal Наименование_валюты As String, Optional ByVal Дата As Date) As Double
    Dim i&, xmldoc, nodeList, xmlNode
    On Error Resume Next
    If Len(Наименование_валюты) <> 3 Then Exit Function Else Дата = UCase(Наименование_валюты)
    If Дата = 0 Then Дата = Date
    Set xmldoc = CreateObject("Msxml.DOMDocument"): xmldoc.async = False
    If Not xmldoc.Load("nbrb.by/Services/XmlExRates.aspx?ondate=" & Format(Дата, "dd\/mm\/yyyy")) Then Exit Function
    Set nodeList = xmldoc.SelectNodes("/Currency")
    For i = 0 To nodeList.Length - 1
        Set xmlNode = nodeList.Item(i)
        If xmlNode.ChildNodes(1).Text = Наименование_валюты Then
            Курс_валюты = CDbl(xmlNode.ChildNodes(4).Text) / Val(xmlNode.ChildNodes(2).Text)
            Exit Function
        End If
    Next i
End Function
Получение данных, используя XML для НБРБ по ссылке http://www.nbrb.by/statistics/Rates/XML/
Заранее при много благодарен.
09.02.2016 15:37:02
Подскажите пожалуйста, как сделать для драгоценных металлов, например для золота? http://www.cbr.ru/hd_base/?PrtId=metall_base_new
пробовал, не получилось, почему-то не работает такой вариант:
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=12/02/2016&date_req2=12/02/2016"
url_request = ("http://www.cbr.ru/scripts/xml_metall.asp?date_req1=" & _
    Format(InputBox("Введите начальную дату поиска в формате ДД.ММ.ГГГГ", "Курс Золота", Date), "dd\/mm\/yyyy") & _
     "&date_req2=" & _
    Format(InputBox("Введите конечную дату поиска в формате ДД.ММ.ГГГГ", "Курс Золота", Date), "dd\/mm\/yyyy"))
   If Not xmldoc.Load(url_request) Then Exit Sub
   Set nodeList = xmldoc.SelectNodes("*/Record[@Code='1'][last()]/Buy")
If nodeList.Length Then ActiveCell.Value = CDbl(nodeList.Item(0).ChildNodes(4).Text)
End Sub
07.02.2018 19:43:28
Макрос, указанный в посте, парсит неправильные данные. Видимо, что-то поменялось в верстке cbr.
Буду признателен, если внесёте правки!
16.12.2018 12:45:22
Да, на сайте ЦБ в очередной раз поменяли дизайн :)
Подправил макрос в статье и приложенном файле - теперь все ОК.
Наверх