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

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

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

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

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

Sub GetDollar()
    Dim sURI As String, oHttp As Object, htmlcode, outstr As String, inpdate As Date
    
    'выводим диалоговое окно с вопросом о дате
    inpdate = CDate(InputBox("Введите дату в формате ДД.ММ.ГГГГ", "Курс доллара", Date))
    
    'формируем строку для веб-запроса
    sURI = "https://cbr.ru/currency_base/daily/?UniDbQuery.Posted=True&UniDbQuery.To=" & Format(inpdate, "DD.MM.YYYY")
    
    'делаем запрос
    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, "") - 22, 7)
    Set oHttp = Nothing
    
    'заменяем точку на запятую и выводим в активную ячейку
    outstr = Replace(outstr, ",", ".")
    ActiveCell.Value = outstr
End Sub

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

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

Для получения курса евро, иены, фунта и других валют необходимо лишь поменять в коде код валюты "USD" на любой нужный вам, например "EUR", "KZT" и т.д.

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

 


Эльмира
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
Да, на сайте ЦБ в очередной раз поменяли дизайн :)
Подправил макрос в статье и приложенном файле - теперь все ОК.
23.04.2020 16:34:10
Добрый день.
В связи с новым дизайном сайта ЦБ обновите статью? )
05.07.2019 08:54:27
Все классно!
Но как прописать так, чтобы не вылетало окошко, а молча брал дату из ячейки?
28.02.2020 13:34:00
Добрый день!
Подскажите, есть макрос, работает на ура, но курс загружает только на рабочие дни, а мне нужен курс на все даты, что изменить в макросе?

Option Explicit

Public Sub Auto_Open()
   If MsgBox("Загрузить курсы валют?", vbQuestion Or vbYesNo) = vbYes Then
       FillRates
   End If
End Sub

Public Function RangeCurrencies_() As Excel.Range
   Set RangeCurrencies_ = ThisWorkbook.Names("currencies").RefersToRange
End Function

Public Function RangeRates_() As Excel.Range
   Set RangeRates_ = ThisWorkbook.Names("rates").RefersToRange
End Function

Public Sub FillRates()
   Dim dateFrom As Long, dateTo As Long
   Dim codeCBRF As String
   Dim calcMode As Excel.XlCalculation
   Dim idx As Long
   
   calcMode = Application.Calculation
   Application.Calculation = xlCalculationManual
   
   dateFrom = ThisWorkbook.Names("startDate").RefersToRange.Value
   dateTo = dateFrom + RangeRates_.Rows.Count - 1
   
   For idx = 2 To RangeCurrencies_.Cells.Count
       FillRates_ dateFrom, dateTo, RangeCurrencies_.Cells(idx, 2), RangeRates_(1, 1), RangeRates_(1, idx)
   Next
   
   Application.Calculation = calcMode
End Sub

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Private Sub FillRates_(nDateFrom As Long, nDateTo As Long, sCBRFCurCode As String, _
               rngDateBeg As Excel.Range, rngValueBeg As Excel.Range)

#If Win32 Or Win64 Then
   Const sRecDateConst As String = "<Record Date="
   Const sValueBegConst As String = "<Value>"
   Const sValueEndConst As String = "</Value>"

   Dim nCount As Long
   Dim oHttp As Object
   Dim sUrl As String, sXML As String
   Dim sRateValue As String, sDate As String
   Dim fRate As Double, nDate As Long
   Dim nPos As Long, nLeftPos As Long, nRightPos As Long
   
   RangeRates_.Worksheet.Range(rngDateBeg, rngDateBeg.Offset(RangeRates_.Rows.Count - 1, 0)).ClearContents
   RangeRates_.Worksheet.Range(rngValueBeg, rngValueBeg.Offset(RangeRates_.Rows.Count - 1, 0)).ClearContents
   nCount = 0

On Error GoTo Err_
   
   sUrl = "http://www.cbr.ru/scripts/XML_dynamic.asp?date_req1=" & Format(nDateFrom, "dd\/mm\/yyyy") & _
                                                   "&date_req2=" & Format(nDateTo, "dd\/mm\/yyyy") & _
                                                   "&VAL_NM_RQ=" & sCBRFCurCode
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 GoTo Err_
On Error GoTo Err_
   
   oHttp.Open "GET", sUrl, False
   oHttp.Send
   sXML = oHttp.responseText
   Set oHttp = Nothing
   
   nPos = 1
   Do
       nLeftPos = InStr(nPos, sXML, sRecDateConst)
       If (nLeftPos <= 0) Then Exit Do
       
       sDate = Mid(sXML, nLeftPos + Len(sRecDateConst) + 1, 10)
       nDate = DateSerial(CLng(Right(sDate, 4)), CLng(Mid(sDate, 4, 2)), CLng(Left(sDate, 2)))
       
       nPos = nLeftPos + Len(sRecDateConst) + 10
       nLeftPos = InStr(nPos, sXML, sValueBegConst) + Len(sValueBegConst)
       nRightPos = InStr(nLeftPos, sXML, sValueEndConst)
       sRateValue = Mid(sXML, nLeftPos, nRightPos - nLeftPos)
       fRate = CDbl(sRateValue)
       
       rngDateBeg.Offset(nCount, 0) = nDate
       rngValueBeg.Offset(nCount, 0) = fRate
       
       nCount = nCount + 1
   Loop
   Exit Sub

Err_:
   MsgBox "Ошибка при загрузке курсов.", vbOKOnly Or vbExclamation
   
#Else ' Mac?
   MsgBox "Операция не поддерживается.", vbOKOnly Or vbExclamation
#End If
End Sub
23.05.2020 23:49:43
Доброго времени суток,
При запросе USD выдал - 0[/td]
При запросе EUR выдал - 8[/td]

Что не так?
Voh
27.05.2020 19:02:54
Здравствуйте. Подскажите пожалуйста, МАКРОС в посте больше не получиться использовать с очередными изменениями на сайте cbr?
Или надо что-то подправить?
Voh
31.05.2020 22:28:47
Или как с этим вообще быть? Никто тему не раскрыл особо на сайте..
Наверх