импорт курсов валют с сайта НБУ

[Jaroslav]

Добрый день. У меня есть готовый код программы импорта курсов валют с сайта НБУ (Украина) (сайт "http://moonexcel.com.ua/kurs-nbu_ua"). Но эта функция почему-то не работает (хотя месяц назад работала). Подскажите, пожалуйста, в чем проблема.

Function NBU_RATE(sCurr$, iiDate As Date)
 'moonexcel.com.ua
 
 ' Пишется так: =Personal.xls!NBU_RATE (код валюты; дата) _
 Код валюти доллара 840, евро 978

 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
   
 sURI = "http://bank.gov.ua/control/uk/curmetal/currency/search?formType=searchFormDate&time_step=daily&date=" & iiDate & "&execute"
 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 Function
 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) '">
 Set Doc = CreateObject("HTMLFile")
 Doc.Write iOnlyTable
 Set b = Doc.all.tags("TABLE")
   
 For Each uTableElement In b
 iRows = uTableElement.Rows.Length
 iCells = uTableElement.Cells.Length
 j = 0
 For k = 1 To iRows
    For l = 1 To 5
        j = j + 1
        massive(k, l) = uTableElement.Cells(j - 1).innerHTML
        If j = uTableElement.Cells.Length Then GoTo 1
    Next l
Next k
1:
 Next uTableElement
   
 For k = 2 To iRows
    For l = 1 To 5
        If massive(k, l) = sCurr Then
            NBU_RATE = Replace(massive(k, 5), ".", ",")
            NBU_RATE = NBU_RATE / massive(k, 3)
        End If
     Next l
Next k
  
Calculate
NextForLoop:
Set oHttp = Nothing
Exit Function
ConnectionError:
End Function

[doober]

Немного сократил код.

Function NBU_RATE(sCurr$, iiDate As Date)
    Dim sURI As String
    Dim oHttp As Object
    Dim htmlcode As String
    sURI = "http://bank.gov.ua/control/uk/curmetal/currency/search?formType=" & _
           "searchFormDate&time_step=daily&date=" & iiDate & "&execute"
    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 Function
    On Error GoTo ConnectionError
    oHttp.Open "GET", sURI, False
    oHttp.Send
    htmlcode = Replace(Replace(oHttp.responseText, vbTab, ""), vbCrLf, "")

    bRes = False
    Set RegExp = CreateObject("VBScript.RegExp")

    RegExp.Pattern = "<tr>\s{1,}<td[^>]*>" & sCurr & "</td>\s{1,}" & _
                     "<td[^>]*>(.+?)</td>\s{1,}" & _
                     "<td[^>]*>([0-9]+)</td>\s{1,}" & _
                     "<td[^>]*>(.+?)</td>\s{1,}" & _
                     "<td[^>]*>([0-9\.]+)</td>"

    bRes = RegExp.test(htmlcode)
    If bRes Then
        Set oMatches = RegExp.Execute(htmlcode)
        NBU_RATE = Val(oMatches(0).subMatches(3)) / oMatches(0).subMatches(1)
        Exit Function
    End If
    Exit Function
ConnectionError:
End Function

[Jaroslav]

Спасибо, Сергей

[demko_n]

Привет. Подскажите, почемо макрос не работает? Вставил ваш код, а курс не видает.

[Aleksandr H.]

Сообщение от demko_n

Привет. Подскажите, почемо макрос не работает? Вставил ваш код, а курс не видает.

Код рабочий

[Djeki]

Сообщение от doober

Немного сократил код.

Код работает..

[sanych_k]

Добрый день ! при обновлении курса на дату выдает 0 !!! подскажите в чем может быть причина

Function NBU_RATE(sCurr$, iiDate As Date)
Dim sURI As String
Dim oHttp As Object
Dim htmlcode As String
sURI = "http://bank.gov.ua/control/uk/curmetal/currency/search?formType=" & _
"searchFormDate&time_step=daily&dat e=" & iiDate & "&execute"
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 Function
On Error GoTo ConnectionError
oHttp.Open "GET", sURI, False
oHttp.Send
htmlcode = Replace(Replace(oHttp.responseText, vbTab, ""), vbCrLf, "")

bRes = False
Set RegExp = CreateObject("VBScript.RegExp")

RegExp.Pattern = "<tr>\s{1,}<td[^>]*>" & sCurr & "</td>\s{1,}" & _
"<td[^>]*>(.+?)</td>\s{1,}" & _
"<td[^>]*>([0-9]+)</td>\s{1,}" & _
"<td[^>]*>(.+?)</td>\s{1,}" & _
"<td[^>]*>([0-9\.]+)</td>"

bRes = RegExp.test(htmlcode)
If bRes Then
Set oMatches = RegExp.Execute(htmlcode)
NBU_RATE = Val(oMatches(0).subMatches(3)) / oMatches(0).subMatches(1)
Exit Function
End If
Exit Function
ConnectionError:
End Function

[Aleksandr H.]

Сравни строки:
Исходник:

"searchFormDate&time_step=daily&date=" & iiDate & "&execute"

У тебя:

"searchFormDate&time_step=daily&dat e=" & iiDate & "&execute"

[Alexanddr]

здравствуйте.
Пишу сюда так как тут суть вопроса очень близка к моей возникшей проблемы.
Излагаю суть проблемы. не знаю и не могу импортировать курс биткоина в эксель таблицу с какой либо биржы или сайта, сколько не старался и не пытался.
Курс доллара импортировал без труда с сайта ЦБ РФ в эксель файл, теперь при открытие файла у меня актуальный курс отображается.
Прошу помочь и разъяснить как это сделать уже с биткоином.
За ранее спасибо за помощь

[Hugo121]

Добрый день.
Покажите в чём разница - а то пока никакой разницы не вижу