Получение курсов валют с сайта Центробанка

На листе имеются две именованные ячейки - "Доллар" и "Евро". При нажатии на кнопку эти ячейки обновляются данными от Центробанка РФ. Данные берутся с сайта Cbr.ru на следующую дату от сегодняшней.
Код макроса:
Option Explicit
'Обновить курсы валют
'Должна быть включена в Tools\References - Microsoft HTML Object Lib!
'http://www.cbr.ru/currency_base/daily.aspx?date_req=28.04.2015
Sub RefreshDollarEuro()
Dim data As String, url As String
ActiveSheet.Range("Евро") = "0"
ActiveSheet.Range("Доллар") = "0"
'делаем запрос на сайт
url = "http://www.cbr.ru/currency_base/daily.aspx"
data = "date_req=" + Format(DateAdd("d", 1, Date), "dd.mm.yyyy") 'на следующую дату от сегодня!
Dim xml As Object
Set xml = CreateObject("MSXML2.ServerXMLHTTP")
With xml
.Open "POST", url, False
.setRequestHeader "Accept", "text/html"
.setRequestHeader "Accept-Charset", "windows-1251"
.setRequestHeader "Keep-Alive", "300"
.setRequestHeader "Connection", "keep-alive"
.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
.send data
End With
'Перегоняем код страницы
Dim htm As Object
Set htm = CreateObject("HTMLFile")
htm.body.innerHTML = xml.responseText
'Просмотрим таблицу
Dim ELtr As IHTMLElement
Dim td As IHTMLElementCollection
data = ""
For Each ELtr In htm.getElementsByTagName("TR")
If InStr(ELtr.innerText, "EUR") > 0 Then
Set td = ELtr.getElementsByTagName("td") 'получим строку с данными
data = td.Item(td.Length - 1).innerText 'достанем последнее значение - это курс
ActiveSheet.Range("Евро") = CDbl(data)
End If
If InStr(ELtr.innerText, "USD") > 0 Then
Set td = ELtr.getElementsByTagName("td")
data = td.Item(td.Length - 1).innerText
ActiveSheet.Range("Доллар") = CDbl(data)
End If
Next ELtr
End Sub

Комментарии

Поп Аввакуум

Зачем тебе курсы валют бесовских, сын мой? Плати рублём, даже иноземцу, истину не разумеющему, пусть славится и ширится слава валюты нашей, а потуги свои в программировании заморском оставь, пустое это всё.

чт, 06/30/2016 - 13:47