Домашняя страница Undo Do New Save Карта сайта Обратная связь Поиск по форуму
МИР MS EXCEL - Гость.xls

Вход

Регистрация

Напомнить пароль

 

= Мир MS Excel/Получить котировки нефти по дням - Мир MS Excel

Старая форма входа
  • Страница 1 из 1
  • 1
Модератор форума: китин, _Boroda_  
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Получить котировки нефти по дням (Макросы/Sub)
Получить котировки нефти по дням
akobir Дата: Четверг, 19.01.2017, 18:10 | Сообщение № 1
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 201
Репутация: 9 ±
Замечаний: 0% ±

Excel 2010
Всем привет!
Не могу разобраться и уже голову всю сломал.
У меня есть код, который вытягивает курсы валют по дням с сайта ЦБ:
[vba]
Код

     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
        MsgBox "Не удалось получить данные!", vbCritical, "Критическая ошибка!" ' Запрос к серверу ЦБР
        Exit Function
    End If

    ' Обработка полученного ответа
    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
[/vba]

Хочу сделать такую же штуку по нефти.
Понятное дело, что ЦБ нефтью не торгует. Хочу выгрузить с Финама или РБК, но совсем не пойму, как это сделать.
Буду признателен!
К сообщению приложен файл: __.xlsm (31.3 Kb)


e-mail: akobir.ismailov@gmail.com

Сообщение отредактировал akobir - Четверг, 19.01.2017, 18:13
 
Ответить
СообщениеВсем привет!
Не могу разобраться и уже голову всю сломал.
У меня есть код, который вытягивает курсы валют по дням с сайта ЦБ:
[vba]
Код

     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
        MsgBox "Не удалось получить данные!", vbCritical, "Критическая ошибка!" ' Запрос к серверу ЦБР
        Exit Function
    End If

    ' Обработка полученного ответа
    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
[/vba]

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

Автор - akobir
Дата добавления - 19.01.2017 в 18:10
Udik Дата: Четверг, 19.01.2017, 18:26 | Сообщение № 2
Группа: Друзья
Ранг: Старожил
Сообщений: 1588
Репутация: 192 ±
Замечаний: 0% ±

Excel 2016 х 64
Вы укажите адреса сайтов, тогда можно что-то сказать. А Ваш код работает с XML файлом, причем отбирает узлы Valute. Вряд ли на других сайтах такое.


вот вам барабан
яд 41001231307558 wm R419131876897
udik1968@gmail.com
 
Ответить
СообщениеВы укажите адреса сайтов, тогда можно что-то сказать. А Ваш код работает с XML файлом, причем отбирает узлы Valute. Вряд ли на других сайтах такое.

Автор - Udik
Дата добавления - 19.01.2017 в 18:26
akobir Дата: Четверг, 19.01.2017, 18:32 | Сообщение № 3
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 201
Репутация: 9 ±
Замечаний: 0% ±

Excel 2010
Udik, Да, я знаю и Вы абсолютно правы!
Адреса сайтов:
Финам
РБК


e-mail: akobir.ismailov@gmail.com
 
Ответить
СообщениеUdik, Да, я знаю и Вы абсолютно правы!
Адреса сайтов:
Финам
РБК

Автор - akobir
Дата добавления - 19.01.2017 в 18:32
Udik Дата: Четверг, 19.01.2017, 21:09 | Сообщение № 4
Группа: Друзья
Ранг: Старожил
Сообщений: 1588
Репутация: 192 ±
Замечаний: 0% ±

Excel 2016 х 64
На этом адресе (финам) только на текущий день. Ну такая заготовка
[vba]
Код

Option Explicit

Public Sub tt()
    Dim txt As String
    Dim RegExp As Object
    Dim rezFind As Object, unoRez As Object
    Dim xhr
    
    Set xhr = CreateObject("WinHttp.WinHttpRequest.5.1")
    xhr.Open "GET", "http://www.finam.ru/profile/tovary/brent/", False
    xhr.send
    txt = xhr.responseText
    Set RegExp = CreateObject("VBScript.RegExp")
    With RegExp
        .Global = True 'Нужны все совпадения
        .IgnoreCase = True 'Регистр неважен
        .Pattern = "issuer-profile-informer.+span>" 'Регулярка
    End With
    Set rezFind = RegExp.Execute(txt)
End Sub

[/vba]
потом из rezFind нужное отобрать.
А на РБК постоянно окошко логин/пароль вылазит .


вот вам барабан
яд 41001231307558 wm R419131876897
udik1968@gmail.com


Сообщение отредактировал Udik - Четверг, 19.01.2017, 21:11
 
Ответить
СообщениеНа этом адресе (финам) только на текущий день. Ну такая заготовка
[vba]
Код

Option Explicit

Public Sub tt()
    Dim txt As String
    Dim RegExp As Object
    Dim rezFind As Object, unoRez As Object
    Dim xhr
    
    Set xhr = CreateObject("WinHttp.WinHttpRequest.5.1")
    xhr.Open "GET", "http://www.finam.ru/profile/tovary/brent/", False
    xhr.send
    txt = xhr.responseText
    Set RegExp = CreateObject("VBScript.RegExp")
    With RegExp
        .Global = True 'Нужны все совпадения
        .IgnoreCase = True 'Регистр неважен
        .Pattern = "issuer-profile-informer.+span>" 'Регулярка
    End With
    Set rezFind = RegExp.Execute(txt)
End Sub

[/vba]
потом из rezFind нужное отобрать.
А на РБК постоянно окошко логин/пароль вылазит .

Автор - Udik
Дата добавления - 19.01.2017 в 21:09
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Получить котировки нефти по дням (Макросы/Sub)
  • Страница 1 из 1
  • 1
Поиск:

Яндекс.Метрика Яндекс цитирования
© 2010-2024 · Дизайн: MichaelCH · Хостинг от uCoz · При использовании материалов сайта, ссылка на www.excelworld.ru обязательна!