Не создает у меня такой объект, (хотя если включить MsgBox, для проверки, ссылка появляется правильная), выходит из процедуры, вот здесь "If Not xmldoc.Load(url_request) Then Exit Sub". А "Msxml.DOMDocument" проходит дальше, и "MSXML2.DOMDocument.6.0" тоже прооходит дальше, но с большой задержкой, но так же код не работает. По курсу доллара и евро "Msxml.DOMDocument" работает нормально, а вот на металлах не хочет, не ищет ничего. В чем проблема может быть? Excel 16, Win10x64. У кого-нибудь хоть работает, пример в предыдущем посте, проверьте пожалуйста.
Не создает у меня такой объект, (хотя если включить MsgBox, для проверки, ссылка появляется правильная), выходит из процедуры, вот здесь "If Not xmldoc.Load(url_request) Then Exit Sub". А "Msxml.DOMDocument" проходит дальше, и "MSXML2.DOMDocument.6.0" тоже прооходит дальше, но с большой задержкой, но так же код не работает. По курсу доллара и евро "Msxml.DOMDocument" работает нормально, а вот на металлах не хочет, не ищет ничего. В чем проблема может быть? Excel 16, Win10x64. У кого-нибудь хоть работает, пример в предыдущем посте, проверьте пожалуйста.IWI
Сообщение отредактировал IWI - Понедельник, 15.02.2016, 23:19
Помогите, дайте рабочий вариант по извлечению курса золота с сайта ЦБ РФ.
[vba]
Код
Sub GetZoloto() Dim xmldoc, nodeList On Error Resume Next Set xmldoc = CreateObject("MSXML2.DOMDocument.4.0"): xmldoc.async = False 'страница выгрузки данных http://www.cbr.ru/scripts/xml_metall.asp?date_req1=12/02/2016&date_req2=12/02/2016 url_request = ("http://www.cbr.ru/scripts/xml_metall.asp?date_req1=" & _ Format(InputBox("Введите начальную дату поиска в формате ДД.ММ.ГГГГ", "Курс Золота", Date), "dd\/mm\/yyyy") & _ "&date_req2=" & _ Format(InputBox("Введите конечную дату поиска в формате ДД.ММ.ГГГГ", "Курс Золота", Date), "dd\/mm\/yyyy")) If Not xmldoc.Load(url_request) Then Exit Sub Set nodeList = xmldoc.SelectNodes("*/Record[@Code='1'][last()]/Buy") If nodeList.Length Then ActiveCell.Value = CDbl(nodeList.Item(0).ChildNodes(4).Text) End Sub
[/vba]
Такой код не работает!
Помогите, дайте рабочий вариант по извлечению курса золота с сайта ЦБ РФ.
[vba]
Код
Sub GetZoloto() Dim xmldoc, nodeList On Error Resume Next Set xmldoc = CreateObject("MSXML2.DOMDocument.4.0"): xmldoc.async = False 'страница выгрузки данных http://www.cbr.ru/scripts/xml_metall.asp?date_req1=12/02/2016&date_req2=12/02/2016 url_request = ("http://www.cbr.ru/scripts/xml_metall.asp?date_req1=" & _ Format(InputBox("Введите начальную дату поиска в формате ДД.ММ.ГГГГ", "Курс Золота", Date), "dd\/mm\/yyyy") & _ "&date_req2=" & _ Format(InputBox("Введите конечную дату поиска в формате ДД.ММ.ГГГГ", "Курс Золота", Date), "dd\/mm\/yyyy")) If Not xmldoc.Load(url_request) Then Exit Sub Set nodeList = xmldoc.SelectNodes("*/Record[@Code='1'][last()]/Buy") If nodeList.Length Then ActiveCell.Value = CDbl(nodeList.Item(0).ChildNodes(4).Text) End Sub
, тем более там всего 2 дочерних элемента - Buy и Sell
3 раз у вас стоит msxml6, то [vba]
Код
Set xmldoc = CreateObject("MSXML2.DOMDocument.6.0")
[/vba](для использования функций в xpath нужна любая версия msxml выше 3)
[vba]
Код
Sub GetZoloto() Dim elem On Error Resume Next With CreateObject("MSXML2.DOMDocument.6.0"): .async = False 'страница выгрузки данных http://www.cbr.ru/scripts/xml_metall.asp?date_req1=12/02/2016&date_req2=12/02/2016 url_request = ("http://www.cbr.ru/scripts/xml_metall.asp?date_req1=" & _ Format(InputBox("Введите начальную дату поиска в формате ДД.ММ.ГГГГ", "Курс Золота", Date), "dd\/mm\/yyyy") & _ "&date_req2=" & _ Format(InputBox("Введите конечную дату поиска в формате ДД.ММ.ГГГГ", "Курс Золота", Date), "dd\/mm\/yyyy")) If Not .Load(url_request) Then Exit Sub Set elem = .SelectSingleNode("*/Record[@Code='1'][last()]/Buy") If Not elem Is Nothing Then ActiveCell.Value = CDbl(elem.Text) Set elem = Nothing End With End Sub
[/vba]
[p.s.]в прошлый раз как-то невнимательно код смотрел, не обратил внимания на последнюю строку
, тем более там всего 2 дочерних элемента - Buy и Sell
3 раз у вас стоит msxml6, то [vba]
Код
Set xmldoc = CreateObject("MSXML2.DOMDocument.6.0")
[/vba](для использования функций в xpath нужна любая версия msxml выше 3)
[vba]
Код
Sub GetZoloto() Dim elem On Error Resume Next With CreateObject("MSXML2.DOMDocument.6.0"): .async = False 'страница выгрузки данных http://www.cbr.ru/scripts/xml_metall.asp?date_req1=12/02/2016&date_req2=12/02/2016 url_request = ("http://www.cbr.ru/scripts/xml_metall.asp?date_req1=" & _ Format(InputBox("Введите начальную дату поиска в формате ДД.ММ.ГГГГ", "Курс Золота", Date), "dd\/mm\/yyyy") & _ "&date_req2=" & _ Format(InputBox("Введите конечную дату поиска в формате ДД.ММ.ГГГГ", "Курс Золота", Date), "dd\/mm\/yyyy")) If Not .Load(url_request) Then Exit Sub Set elem = .SelectSingleNode("*/Record[@Code='1'][last()]/Buy") If Not elem Is Nothing Then ActiveCell.Value = CDbl(elem.Text) Set elem = Nothing End With End Sub
[/vba]
[p.s.]в прошлый раз как-то невнимательно код смотрел, не обратил внимания на последнюю строкуkrosav4ig
krosav4ig, отлично, теперь работает. А почему же с "Msxml.DOMDocument" не работало, какие недочеты были, что надо исправить, если не трудно объясните для понимания функции. И подскажите, что надо вставить в MsgBox, чтоб вывести на экран, то что будет копироваться, это мне надо для отладки. Спасибо!
krosav4ig, отлично, теперь работает. А почему же с "Msxml.DOMDocument" не работало, какие недочеты были, что надо исправить, если не трудно объясните для понимания функции. И подскажите, что надо вставить в MsgBox, чтоб вывести на экран, то что будет копироваться, это мне надо для отладки. Спасибо!IWI
Сообщение отредактировал IWI - Среда, 17.02.2016, 10:37
Останавливает ошибку, на этой строчке. Что-то не так. Я с самого начала так и сделал, но попробовал не получается, потому сюда и решил обратиться за помощью. Ув. _Boroda_, спасибо, что откликнулись и не бросаете!
Останавливает ошибку, на этой строчке. Что-то не так. Я с самого начала так и сделал, но попробовал не получается, потому сюда и решил обратиться за помощью. Ув. _Boroda_, спасибо, что откликнулись и не бросаете!IWI
Сообщение отредактировал IWI - Понедельник, 12.09.2016, 17:05
Sub Investing_1_Usd() Dim sURI As String Dim oHttp As Object Dim htmlcode, outstr As String
sURI = "http://ru.investing.com/currencies/usd-rub/" 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, "Спрос/Предл") + 76, 6) 'для покупки 131 Set oHttp = Nothing 'outstr = Replace(outstr, ",", ".") ActiveCell.Value = CSng(outstr) + 0.35 End Sub
[/vba] Да и без CSng тоже нормально
У мня так работает [vba]
Код
Sub Investing_1_Usd() Dim sURI As String Dim oHttp As Object Dim htmlcode, outstr As String
sURI = "http://ru.investing.com/currencies/usd-rub/" 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, "Спрос/Предл") + 76, 6) 'для покупки 131 Set oHttp = Nothing 'outstr = Replace(outstr, ",", ".") ActiveCell.Value = CSng(outstr) + 0.35 End Sub
Sub EUR_покупка_продажа_2() Dim sURI As String Dim oHttp As Object Dim htmlcode, outstr As String
sURI = "http://www.homecredit.ru/" 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") + 1499, 5) 'aey i?iaa?e aaieii 1449 eciaieou ia 1499 Set oHttp = Nothing outstr = Replace(outstr, ".", ",") ActiveCell.Value = CSng(outstr) + 0.35 End Sub
[/vba] Попробуйте и для первого варианта
А так? [vba]
Код
Sub EUR_покупка_продажа_2() Dim sURI As String Dim oHttp As Object Dim htmlcode, outstr As String
sURI = "http://www.homecredit.ru/" 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") + 1499, 5) 'aey i?iaa?e aaieii 1449 eciaieou ia 1499 Set oHttp = Nothing outstr = Replace(outstr, ".", ",") ActiveCell.Value = CSng(outstr) + 0.35 End Sub
Вход
Регистрация
Напомнить пароль
Автосумма
Часто используемые
ВПР
ЕСЛИ
СУММЕСЛИ
Финансовые
Логические
Текстовые
Даты и времени 
Ссылки и массивы 
Математические
Другие функции
Проверка свойств и значений
Баз данных
Математические
Обработки массивов
Обработки строк
Преобразования типов данных 
Загрузки данных
Работы с файлами
Обработки системных параметров
Обработки цвета
Работы с датами и временем
Преобразования в системы счисления
Финансовые
