Форум программистов
 

Восстановите пароль или Зарегистрируйтесь на форуме, о проблемах и с заказом рекламы пишите сюда - alarforum@yandex.ru, проверяйте папку спам!

Вернуться   Форум программистов > Microsoft Office и VBA программирование > Microsoft Office Excel
Регистрация

Восстановить пароль
Повторная активизация e-mail

Купить рекламу на форуме - 42 тыс руб за месяц

Ответ
 
Опции темы Поиск в этой теме
Старый 05.05.2017, 09:55   #11
Serge_Bliznykov
Старожил
 
Регистрация: 09.01.2008
Сообщений: 26,238
По умолчанию

я не специалист в VBA и не знаю, где Вы смотрите курс биткоина.
но вот можете попробовать такой код:
Код:
Public Function BITCOIN_RATE()
    Dim sURI As String
    Dim oHttp As Object
    Dim htmlcode As String
    Dim bRes As Boolean, RegExp As Object, oMatches As Object
        
    sURI = "https://www.calc.ru/kurs-BTC-RUB.html"
    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 = "<b>1 bitcoin \(BTC\)</b>.*?<b>(.*?)</b>"
    
    bRes = RegExp.test(htmlcode)
    BITCOIN_RATE = "#nod found#"
    If bRes Then
        Set oMatches = RegExp.Execute(htmlcode)
        BITCOIN_RATE = oMatches(0).subMatches(0)
        Exit Function
    End If
    Exit Function
ConnectionError:
End Function

пример: КнигаHtml_get.rar
Serge_Bliznykov вне форума Ответить с цитированием
Старый 05.05.2017, 14:33   #12
Alexanddr
Новичок
Джуниор
 
Регистрация: 05.05.2017
Сообщений: 2
По умолчанию

Прошу общаться со мной как с лабрадором, так как в этой области ни чего не понимаю.
поясните пожалуйста как мне это применить, внедрить в ексель.
объясню пошагово как я импортировал курс доллара.
1. посмотрел видео на ютуб как это сделать, там просто, и неопытному пользователю, который не разбирается в программировании, легко и доступно объяснено.
2. Зашел на сайт - http://www.cbr.ru/scripts/Root.asp?PrtId=SXML
3. скопировал в буфер www.cbr.ru/scripts/XML_daily.asp?
4. в экселе - выбрал закладку ДАННЫЕ->ПОЛУЧЕНИЕ ВНЕШНИХ ДАННЫХ->ИЗ ИНТЕРНЕТА
5. открыл http://www.cbr.ru/scripts/Root.asp?PrtId=SXML
6. импортировал
7. получил результат

P.S.- курс биткоина в USD смотрю в яндексе, или https://poloniex.com/exchange#usdt_btc, а так подойдет любой достоверный источник. но желательно - https://poloniex.com/exchange#usdt_btc
За ранее прошу меня извинить что я краду ваше время и прошу разъяснения как мне это сделать

Последний раз редактировалось Alexanddr; 05.05.2017 в 15:40.
Alexanddr вне форума Ответить с цитированием
Старый 15.02.2018, 17:44   #13
islavuta
Новичок
Джуниор
 
Регистрация: 17.11.2016
Сообщений: 1
По умолчанию

Несколько лет работал у меня этот макрос, а где-то в январе 2018 стал выдавать 0 (ноль) . Может, НБУ изменил формат данных?
Помогите, кто силЕн, отредактировать макрос, пожалуйста.
islavuta вне форума Ответить с цитированием
Старый 15.02.2018, 17:50   #14
Hugo121
Старожил
 
Регистрация: 11.05.2010
Сообщений: 5,166
По умолчанию

Говорят там теперь в адрес нужно "s" добавить: https
Я сам не видел, да и Вы не показали "этот" макрос, я говорю про название темы
webmoney: E265281470651 Z422237915069 R418926282008
Hugo121 вне форума Ответить с цитированием
Старый 15.02.2018, 20:33   #15
Aleksandr H.
2 the Nation Glory
Старожил
 
Аватар для Aleksandr H.
 
Регистрация: 27.05.2014
Сообщений: 3,289
По умолчанию

Подтверждаю. В адресс надо s добавить
Кто умер, но не забыт, тот бессмертен.
Лао-Цзы.
Aleksandr H. вне форума Ответить с цитированием
Старый 05.08.2018, 21:32   #16
ОксанаАК
Новичок
Джуниор
 
Регистрация: 05.08.2018
Сообщений: 2
По умолчанию

Цитата:
Сообщение от Aleksandr H. Посмотреть сообщение
Подтверждаю. В адресс надо s добавить
Доброго дня.
Добавила в адресную строку s, но всё равно выдаёт результат "0".
Может ещё что-то надо сделать?
ОксанаАК вне форума Ответить с цитированием
Старый 05.08.2018, 21:47   #17
Hugo121
Старожил
 
Регистрация: 11.05.2010
Сообщений: 5,166
По умолчанию

Да. Нужно показать файл с этим кодом.
webmoney: E265281470651 Z422237915069 R418926282008
Hugo121 вне форума Ответить с цитированием
Старый 06.08.2018, 18:17   #18
Куреша
Новичок
Джуниор
 
Регистрация: 18.04.2013
Сообщений: 2
По умолчанию

Цитата:
Сообщение от Hugo121 Посмотреть сообщение
Да. Нужно показать файл с этим кодом.
Тоже перестало работать. Выдает Ноль:
Цитата:
Function NBU_RATE(sCurr$, iiDate As Date)
Dim sURI As String
Dim oHttp As Object
Dim htmlcode As String
sURI = "https://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
При этом, как я понимаю, строка, содержащая ссылку, правильная. Если ввести вручную в браузере, то на страницу НБУ заходит...
А вот что поломалось...

Последний раз редактировалось Куреша; 06.08.2018 в 18:19.
Куреша вне форума Ответить с цитированием
Старый 06.08.2018, 18:29   #19
Куреша
Новичок
Джуниор
 
Регистрация: 18.04.2013
Сообщений: 2
По умолчанию

Нашел временное решение:
Код:
Public Function NBUCURRENCY(currencyName As String, key As String, currencyDate As Date)
Dim sURI As String, oHttp As Object
    sURI = "https:" & Chr(47) & Chr(47) & "bank.gov.ua" & Chr(47) & "NBUStatService" & Chr(47) & "v1" & Chr(47) & "statdirectory" & Chr(47) & "exchange?valcode=" & currencyName & "&date=" & Format(currencyDate, "yyyymmdd") & "&json"
    Set oHttp = CreateObject("MSXML2.XMLHTTP")
    If oHttp Is Nothing Then Exit Function
    On Error GoTo ConnectionError
    oHttp.Open "GET", sURI, False
    On Error GoTo ConnectionError
    oHttp.Send
    NBUCURRENCY = jsonParse(oHttp.responseText, key)
ConnectionError:
    Set oHttp = Nothing
End Function
Private Function jsonParse(jsonStr As String, key As String)
    arr = Split(Replace(Replace(jsonStr, "[{", ""), "}]", ""), ",")
    For Each el In arr
        arr2 = Split(el, ":")
        arr2(0) = Replace(arr2(0), Chr(34), "")
        If arr2(0) = key Then
            If arr2(0) = "rate" Then jsonParse = CDbl(Replace(arr2(1), ".", ",")) Else: jsonParse = Replace(arr2(1), Chr(34), "")
            Exit For
        End If
    Next
End Function
Примітка: Код функції необхідно розмістити у власному модулі (VBE->Insert->Module). Інакше функцію не буде видно аркуші і відповідно не буде обчислено!

Приклад:
Все тепер можна завантажувати дані на будь який аркуш в Excel як звичайною формулою
Код:
=NBUCURRENCY("USD";"r030";DATE(2017;9;6))    'Отримаємо = 840'
=NBUCURRENCY("USD";"txt";DATE(2017;9;6))    'Отримаємо = Долар США'
=NBUCURRENCY("USD";"rate";DATE(2017;9;6))    'Отримаємо = 25,954263'
=NBUCURRENCY("USD";"cc";DATE(2017;9;6))        'Отримаємо = USD'
=NBUCURRENCY("USD";"exchangedate";DATE(2017;9;6))    'Отримаємо = 06.09.2017
_____
Код программы нужно выделять (форматировать) тегами [CODE] (читать FAQ)
Модератор

Последний раз редактировалось Serge_Bliznykov; 06.08.2018 в 22:56.
Куреша вне форума Ответить с цитированием
Старый 07.08.2018, 09:56   #20
Litvik7
 
Регистрация: 07.08.2018
Сообщений: 4
По умолчанию

еще как вариант:

Код:
Function GetNBURate(ByVal CurrencyName As String, ByVal RateDate As Date) As Double
On Error Resume Next
Dim CurrencyRate As Double
CurrencyName = UCase(CurrencyName): If Len(CurrencyName) <> 3 Then Exit Function
Set xmldoc = CreateObject("Msxml.DOMDocument"): xmldoc.async = False
url_request = "https://bank.gov.ua/NBUStatService/v1/statdirectory/exchange?date=" & Format(RateDate, "yyyymmdd")
If xmldoc.Load(url_request) <> True Then Exit Function
Set nodeList = xmldoc.SelectNodes("/exchange/currency")
 For i = 0 To nodeList.Length - 1
Set xmlNode = nodeList.Item(i).CloneNode(True)
If xmlNode.ChildNodes(3).Text = CurrencyName Then
CurrencyRate = Val(Replace(xmlNode.ChildNodes(2).Text, ",", "."))
GetNBURate = CurrencyRate
Exit Function
End If
Next
End Function
вид валюты указывать не кодом, а как USD, EUR и т.п.
Litvik7 вне форума Ответить с цитированием
Ответ


Купить рекламу на форуме - 42 тыс руб за месяц

Опции темы Поиск в этой теме
Поиск в этой теме:

Расширенный поиск


Похожие темы
Тема Автор Раздел Ответов Последнее сообщение
Фрактальный анализ курсов валют N@stya Фриланс 4 01.06.2014 12:16
Обновление курсов валют Che Guevara PHP 1 10.02.2012 12:38
Скрипт для загрузки курсов валют с сайта http://www.rbc.ua/ ARseny PHP 0 07.06.2008 22:16
Загрузка курсов валют с сайта Paul Hindenburg Работа с сетью в Delphi 1 25.05.2008 20:48
Загрузка курсов валют 69angel69 Microsoft Office Excel 3 09.04.2008 20:44