'Получить курс Евро на дату
Sub GetEuro()
Range("B12").Select
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("Введите дату в формате DD.MM.YYYY", _
"Курс Евро", Date))
d = Format(inpdate, "dd")
m = Format(inpdate, "mm")
y = Format(inpdate, "yyyy")
sURI = "http://WWW.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
htmlcode = oHttp.responseText
outstr = Mid(htmlcode, InStr(1, htmlcode, "EUR") + 81, 7)
Set oHttp = Nothing
outstr = Replace(outstr, ",", ".")
ActiveCell.Value = outstr
End Sub
Sub GetEuro()
Range("B12").Select
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("Введите дату в формате DD.MM.YYYY", _
"Курс Евро", Date))
d = Format(inpdate, "dd")
m = Format(inpdate, "mm")
y = Format(inpdate, "yyyy")
sURI = "http://WWW.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
htmlcode = oHttp.responseText
outstr = Mid(htmlcode, InStr(1, htmlcode, "EUR") + 81, 7)
Set oHttp = Nothing
outstr = Replace(outstr, ",", ".")
ActiveCell.Value = outstr
End Sub
Комментариев нет:
Отправить комментарий