Данный код (пользовательская функция) позволяет получить данные о курсе валюты с сайта Центробанка.
Данную функцию можно использовать и в виде формулы на листе 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
написать макрос для пересчета вы сможете, если не будете лениться, и поищете в интернете, что такое макросы, и куда их вставлять.
макрос будет из одной строки: (вставить код надо в модуль ЭтаКнига)
под нацбанк украины - много раз люди писали макросы. осталось только поискать в гугле готовое решение...
Очень нужен данный макрос 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 функция для импорта курсов валют с сайта НБУ
Ну как это не работает... есть же пример использования функции:
Как видите, показывает точный сегодняшний курс доллара с сайта центробанка.
Заметил интересную особенность. Иногда отображает курс ЕВРО (на остальных не проверял) на будущую дату
Дата: 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.
Да, есть такая проблема, - когда писал макрос, не обратил на это внимания.
Чтобы избежать ошибки, надо заменить строку кода
на строку
(короче, поменять 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 вообще не силен, может быть, выше приведенный макрос (по ссылке) подскажет вам возможное решение возникшей у меня проблемы?
Отправить комментарий