Ну, в общем-то каков вопрос, таков и ответ А если серьёзно, то можно, но ведь все макросы работают на принципе разбора конкретных Html-кодов с конкретных сайтов, т.к. нет стандарта представления информации с жёстко заданными именами полей записей баз данных.
Ну, в общем-то каков вопрос, таков и ответ А если серьёзно, то можно, но ведь все макросы работают на принципе разбора конкретных Html-кодов с конкретных сайтов, т.к. нет стандарта представления информации с жёстко заданными именами полей записей баз данных.Alex_ST
Уважаемый Андрей {krosav4ig} ! Из Вашего поста №57 у меня не получилось "прикрутить" котировки драгоценных металлов - ОМС Сбербанка со страницы http://data.sberbank.ru/oryol/ru/quotes/metal/ чтобы выводились в ячейки B2 и B3 - покупка/продажа золота соответственно и в ячейки C2 и C3 - покупка/продажа серебра соответственно на текущий день в формате 0,00 р. Подскажите как реализовать?!? Остальные металлы не интересуют!
Уважаемый Андрей {krosav4ig} ! Из Вашего поста №57 у меня не получилось "прикрутить" котировки драгоценных металлов - ОМС Сбербанка со страницы http://data.sberbank.ru/oryol/ru/quotes/metal/ чтобы выводились в ячейки B2 и B3 - покупка/продажа золота соответственно и в ячейки C2 и C3 - покупка/продажа серебра соответственно на текущий день в формате 0,00 р. Подскажите как реализовать?!? Остальные металлы не интересуют!savafso
Сообщение отредактировал savafso - Понедельник, 06.04.2015, 16:04
errGetData: On Error Resume Next Range(objRng, objRng.Offset(1, 1)).Value = "Нет данных" objIE.Quit End Sub
P.S: Работает пока структуру сайта не поменяют Помещает в область указанную в strRange (ИмяЛиста! ячейка) данные с сайта или "Нет данных", если не удалось их получить. iTimeOut - время ожидания в секундах.
Готовый файл приложен...
Вопрос с котировками ОМС Сбербанка решился, спасибо Киру! Готовый скрипт на VBA
Private Sub Workbook_Open() Const strSite As String = "http://data.sberbank.ru/oryol/ru/quotes/metal" Const strSiteTableClass As String = "table3_eggs4" Const strRange As String = "Лист1!A1" Const iTimeOut As Integer = 5
On Error GoTo errGetData Dim objRng As Range Dim objIE As Object Dim objData As Object Dim dtStart As Date
Set objRng = Range(strRange) Set objIE = CreateObject("InternetExplorer.Application") objIE.Visible = False
dtStart = Now() objIE.Navigate strSite
While objIE.Busy Or objIE.ReadyState <> 4 DoEvents If DateDiff("s", Now(), dtStart) >= iTimeOut Then Err.Raise vbObjectError, , "Timeout" End If Wend
errGetData: On Error Resume Next Range(objRng, objRng.Offset(1, 1)).Value = "Нет данных" objIE.Quit End Sub
P.S: Работает пока структуру сайта не поменяют Помещает в область указанную в strRange (ИмяЛиста! ячейка) данные с сайта или "Нет данных", если не удалось их получить. iTimeOut - время ожидания в секундах.
Вопрос: если вдруг структура поменяется, то достаточно заново определить местоположение цифр с курсом, но как их найти ? Есть значение в макросе Const strSiteTableClass As String = "table3_eggs4" , где этот table3_eggs4 спрятался ?
Вопрос: если вдруг структура поменяется, то достаточно заново определить местоположение цифр с курсом, но как их найти ? Есть значение в макросе Const strSiteTableClass As String = "table3_eggs4" , где этот table3_eggs4 спрятался ?Rama
1. Я не правильно выразился...где на странице сайта найти table3_eggs4 ? Если структура поменяется, то поменяется и table3_eggs4. Как определить table3_eggs4 на странице сайта 2. Код протестировал, цифры по формату ставлю 4 знака, а он мне опять один/два знака дает. Что поправить 3. Если я меняю название страницы, то ошибка то же
1. Я не правильно выразился...где на странице сайта найти table3_eggs4 ? Если структура поменяется, то поменяется и table3_eggs4. Как определить table3_eggs4 на странице сайта 2. Код протестировал, цифры по формату ставлю 4 знака, а он мне опять один/два знака дает. Что поправить 3. Если я меняю название страницы, то ошибка то жеRama
вставил описаную функцию но она не работает у меня, может чего не сделал? [moder]Нет, как раз наоборот, сделал - влез в тему ветки "Готовые решения" с вопросом. Идите обратно в свою тему. И Правила форума еще раз прочитайте.
вставил описаную функцию но она не работает у меня, может чего не сделал? [moder]Нет, как раз наоборот, сделал - влез в тему ветки "Готовые решения" с вопросом. Идите обратно в свою тему. И Правила форума еще раз прочитайте.Gameower
), 3й столбец (C:C) -курс USD (отлично отрабатывает через ваш макрос с crb.ru), так вот, как я не крутился, не получается у меня изменить Ваш макрос так, что бы он на ту дату по которой мы 2жды кликаем (в столбце А:А), брал с сайта nbrb.by курс росийского рубля и заносил в столбец B:B в ячейку напротив даты по которой кликаем и с сайта crb.ru брал курс USD и заносил в столбец C:C в ячейку напротив даты по которой кликаем. Я ну очень извиняюсь за наглость, опыта у меня в программировании не много, надеюсь Вы подскажете как правильно изменить, Спасибо!
Уважаемый Alex_ST, может вы сможете помочь, есть некоторая таблица эксель, 1й столбец (А:А) - дата, 2й столбец (B:B) - курс RUR (необходимо брать из
), 3й столбец (C:C) -курс USD (отлично отрабатывает через ваш макрос с crb.ru), так вот, как я не крутился, не получается у меня изменить Ваш макрос так, что бы он на ту дату по которой мы 2жды кликаем (в столбце А:А), брал с сайта nbrb.by курс росийского рубля и заносил в столбец B:B в ячейку напротив даты по которой кликаем и с сайта crb.ru брал курс USD и заносил в столбец C:C в ячейку напротив даты по которой кликаем. Я ну очень извиняюсь за наглость, опыта у меня в программировании не много, надеюсь Вы подскажете как правильно изменить, Спасибо!Fantom-by
Сообщение отредактировал Fantom-by - Четверг, 11.02.2016, 21:58
Я так понимаю, что нужно переделать UDF так, чтобы не с банка РФ брало, а с Беларуси? Это-то как раз и самое неприятное и требующее долгой возни - сделать запрос на страничку на сервере так, чтобы он правильно понял и внятно ответил. Тут как раз я не силён - в первом же посте писАл, что основа - от Павла (Pavel55) с Планеты. Да и времени у меня сейчас совсем на работе свободного не стало. А дома я не пишу. Но где-то здесь на форуме или на Планете я уже, кажется, видел, что с банка Беларуси считывают курсы... Пошарьте Поиском по форуму. --------- За 1 минуту, выйдя на главную форума, нашёл по строке nbrb.by в этом же топике нечто похожее в ЭТОМ посте Ройте дальше сами.
Я так понимаю, что нужно переделать UDF так, чтобы не с банка РФ брало, а с Беларуси? Это-то как раз и самое неприятное и требующее долгой возни - сделать запрос на страничку на сервере так, чтобы он правильно понял и внятно ответил. Тут как раз я не силён - в первом же посте писАл, что основа - от Павла (Pavel55) с Планеты. Да и времени у меня сейчас совсем на работе свободного не стало. А дома я не пишу. Но где-то здесь на форуме или на Планете я уже, кажется, видел, что с банка Беларуси считывают курсы... Пошарьте Поиском по форуму. --------- За 1 минуту, выйдя на главную форума, нашёл по строке nbrb.by в этом же топике нечто похожее в ЭТОМ посте Ройте дальше сами.Alex_ST
С уважением, Алексей MS Excel 2003 - the best!!!
Сообщение отредактировал Alex_ST - Четверг, 11.02.2016, 22:44
Function НБРБ(Optional ByVal Curr$ = "USD", Optional ByVal dDate As Date) As Currency Dim ondate$ With CreateObject("msxml.DOMDocument") ondate = "?ondate=" & Format(IIf(dDate, dDate, Date), "mm/dd/yyyy") .async = 0: .Load "http://www.nbrb.by/Services/XmlExRates.aspx" & ondate With .SelectSingleNode("*/Currency[CharCode='" & UCase(Curr) & "']") НБРБ = CCur(.ChildNodes(4).Text) / Val(.ChildNodes(2).Text) End With End With End Function
[/vba]
Fantom-by, можно как-то так
[vba]
Код
Function НБРБ(Optional ByVal Curr$ = "USD", Optional ByVal dDate As Date) As Currency Dim ondate$ With CreateObject("msxml.DOMDocument") ondate = "?ondate=" & Format(IIf(dDate, dDate, Date), "mm/dd/yyyy") .async = 0: .Load "http://www.nbrb.by/Services/XmlExRates.aspx" & ondate With .SelectSingleNode("*/Currency[CharCode='" & UCase(Curr) & "']") НБРБ = CCur(.ChildNodes(4).Text) / Val(.ChildNodes(2).Text) End With End With End Function
Вариант функций через XML запрос с сайта ЦБР Function GetUSD(Optional ByVal MyDate As Date) As Double Dim xmldoc, nodeList If MyDate = 0 Then MyDate = Date On Error Resume Next Set xmldoc = CreateObject("Msxml.DOMDocument"): xmldoc.async = False If Not xmldoc.Load("http://www.cbr.ru/scripts/XML_daily.asp?date_req=" & Format(MyDate, "dd\/mm\/yyyy")) Then Exit Function Set nodeList = xmldoc.SelectNodes("//Valute[@ID='R01235']") If nodeList.Length Then GetUSD = CDbl(nodeList.Item(0).ChildNodes(4).Text) End Function
Function GetEUR(Optional ByVal MyDate As Date) As Double Dim xmldoc, nodeList If MyDate = 0 Then MyDate = Date On Error Resume Next Set xmldoc = CreateObject("Msxml.DOMDocument"): xmldoc.async = False If Not xmldoc.Load("http://www.cbr.ru/scripts/XML_daily.asp?date_req=" & Format(MyDate, "dd\/mm\/yyyy")) Then Exit Function Set nodeList = xmldoc.SelectNodes("//Valute[@ID='R01239']") If nodeList.Length Then GetEUR = CDbl(nodeList.Item(0).ChildNodes(4).Text) End Function
Доброй ночи! А подкажите можно ли объединить эти две функции чтобы в итого получалась одно значение (кросс-курс): то есть курс Евро поделеный на курс Доллара на текущую дату. Сейчас эти функции сидят в двух ячейках, а кросс-курс считаеся в третьей. И уже оттуда значение копипастится по необходимости макросом в ячейку, связанную с расчетами. Как то все тяжеловато и перенасыщенно получается.
Вариант функций через XML запрос с сайта ЦБР Function GetUSD(Optional ByVal MyDate As Date) As Double Dim xmldoc, nodeList If MyDate = 0 Then MyDate = Date On Error Resume Next Set xmldoc = CreateObject("Msxml.DOMDocument"): xmldoc.async = False If Not xmldoc.Load("http://www.cbr.ru/scripts/XML_daily.asp?date_req=" & Format(MyDate, "dd\/mm\/yyyy")) Then Exit Function Set nodeList = xmldoc.SelectNodes("//Valute[@ID='R01235']") If nodeList.Length Then GetUSD = CDbl(nodeList.Item(0).ChildNodes(4).Text) End Function
Function GetEUR(Optional ByVal MyDate As Date) As Double Dim xmldoc, nodeList If MyDate = 0 Then MyDate = Date On Error Resume Next Set xmldoc = CreateObject("Msxml.DOMDocument"): xmldoc.async = False If Not xmldoc.Load("http://www.cbr.ru/scripts/XML_daily.asp?date_req=" & Format(MyDate, "dd\/mm\/yyyy")) Then Exit Function Set nodeList = xmldoc.SelectNodes("//Valute[@ID='R01239']") If nodeList.Length Then GetEUR = CDbl(nodeList.Item(0).ChildNodes(4).Text) End Function
Доброй ночи! А подкажите можно ли объединить эти две функции чтобы в итого получалась одно значение (кросс-курс): то есть курс Евро поделеный на курс Доллара на текущую дату. Сейчас эти функции сидят в двух ячейках, а кросс-курс считаеся в третьей. И уже оттуда значение копипастится по необходимости макросом в ячейку, связанную с расчетами. Как то все тяжеловато и перенасыщенно получается.Serge1400
Сообщение отредактировал Serge1400 - Воскресенье, 24.07.2016, 11:32
Изменить макрос - просто добавить во второй то, что есть в первом, но отсутствует во втором Примерно так (в код не вникал вообще, просто тупо добавил отсутствующее) [vba]
Код
Function GetEUR_USD(Optional ByVal MyDate As Date) As Double Dim xmldoc, nodeList If MyDate = 0 Then MyDate = Date On Error Resume Next Set xmldoc = CreateObject("Msxml.DOMDocument"): xmldoc.async = False If Not xmldoc.Load("http://www.cbr.ru/scripts/XML_daily.asp?date_req=" & Format(MyDate, "dd\/mm\/yyyy")) Then Exit Function Set nodeList1 = xmldoc.SelectNodes("//Valute[@ID='R01235']") Set nodeList2 = xmldoc.SelectNodes("//Valute[@ID='R01239']") If nodeList1.Length And nodeList.Length2 Then GetEUR_USD = CDbl(nodeList2.Item(0).ChildNodes(4).Text / nodeList1.Item(0).ChildNodes(4).Text) End If End Function
[/vba]
Самое простое - написать вот так
Код
=GetEUR()/GetUSD()
Изменить макрос - просто добавить во второй то, что есть в первом, но отсутствует во втором Примерно так (в код не вникал вообще, просто тупо добавил отсутствующее) [vba]
Код
Function GetEUR_USD(Optional ByVal MyDate As Date) As Double Dim xmldoc, nodeList If MyDate = 0 Then MyDate = Date On Error Resume Next Set xmldoc = CreateObject("Msxml.DOMDocument"): xmldoc.async = False If Not xmldoc.Load("http://www.cbr.ru/scripts/XML_daily.asp?date_req=" & Format(MyDate, "dd\/mm\/yyyy")) Then Exit Function Set nodeList1 = xmldoc.SelectNodes("//Valute[@ID='R01235']") Set nodeList2 = xmldoc.SelectNodes("//Valute[@ID='R01239']") If nodeList1.Length And nodeList.Length2 Then GetEUR_USD = CDbl(nodeList2.Item(0).ChildNodes(4).Text / nodeList1.Item(0).ChildNodes(4).Text) End If End Function
[moder]Цитата удалена[/moder] Саша,и еще раз помог! Я про первый вариант даже не догадывался. А второй по чесноку сам пытался по такому же алгоритму слепить, но очевидно что-то все таки не так делал. Не работает мой вариант, в отличие от твоего.
[moder]Цитата удалена[/moder] Саша,и еще раз помог! Я про первый вариант даже не догадывался. А второй по чесноку сам пытался по такому же алгоритму слепить, но очевидно что-то все таки не так делал. Не работает мой вариант, в отличие от твоего.Serge1400
Сообщение отредактировал Pelena - Воскресенье, 24.07.2016, 14:19
Разбираться надо. А мне некогда... Вот текст процедуры с подправленным запросом : [vba]
Код
Function КурсЕвро(Optional ByVal Дата) As Currency ' запрос курса Евро с сайта ЦБ РФ '--------------------------------------------------------------------------------------- ' Procedure : КурсЕвро ' Author : Основа - Pavel55, коррекция - Alex_ST: 2010-01-28 ' URL : http://www.planetaexcel.ru/forum.php?thread_id=6870&page_forum=2&allnum_forum=34 ' Date : 28.01.2010 ' Purpose : Запрос курса Евро, установленного ЦБР на заданную дату ' Notes : По умолчанию - текущая дата '--------------------------------------------------------------------------------------- Dim Запрос$, Ответ$, Курс$ Dim oHttp As Object Dim ДЕНЬ$, Месяц$, ГОД$ Application.Volatile If IsMissing(Дата) Then Дата = Date If Not IsDate(Дата) Then Дата = CDate(Дата) ДЕНЬ = Format(Дата, "dd"): Месяц = Format(Дата, "mm"): ГОД = Format(Дата, "yyyy") ' Запрос = "http://cbr.ru/currency_base/daily.aspx?C_month=" & Месяц & "&C_year=" & ГОД & "&date_req=" & ДЕНЬ & "%2F" & Месяц & "%2F" & ГОД Запрос = "http://cbr.ru/currency_base/daily/?date_req=" & ДЕНЬ & "%2F" & Месяц & "%2F" & ГОД On Error Resume Next Set oHttp = CreateObject("MSXML2.XMLHTTP") If Err.Number <> 0 Then Set oHttp = CreateObject("MSXML.XMLHTTPRequest") On Error GoTo 0 If oHttp Is Nothing Then Exit Function oHttp.Open "GET", Запрос, False oHttp.Send Ответ = UCase(oHttp.responseText) Курс = CCur(Mid(Ответ, InStr(InStr(1, Ответ, "EUR"), Ответ, "</TD></TR>") - 7, 7)) Set oHttp = Nothing КурсЕвро = Курс End Function
[/vba] Сейчас мне ковыряться, к сожалению, некогда… Может быть кто-то из знамоков посмотрит?
Разбираться надо. А мне некогда... Вот текст процедуры с подправленным запросом : [vba]
Код
Function КурсЕвро(Optional ByVal Дата) As Currency ' запрос курса Евро с сайта ЦБ РФ '--------------------------------------------------------------------------------------- ' Procedure : КурсЕвро ' Author : Основа - Pavel55, коррекция - Alex_ST: 2010-01-28 ' URL : http://www.planetaexcel.ru/forum.php?thread_id=6870&page_forum=2&allnum_forum=34 ' Date : 28.01.2010 ' Purpose : Запрос курса Евро, установленного ЦБР на заданную дату ' Notes : По умолчанию - текущая дата '--------------------------------------------------------------------------------------- Dim Запрос$, Ответ$, Курс$ Dim oHttp As Object Dim ДЕНЬ$, Месяц$, ГОД$ Application.Volatile If IsMissing(Дата) Then Дата = Date If Not IsDate(Дата) Then Дата = CDate(Дата) ДЕНЬ = Format(Дата, "dd"): Месяц = Format(Дата, "mm"): ГОД = Format(Дата, "yyyy") ' Запрос = "http://cbr.ru/currency_base/daily.aspx?C_month=" & Месяц & "&C_year=" & ГОД & "&date_req=" & ДЕНЬ & "%2F" & Месяц & "%2F" & ГОД Запрос = "http://cbr.ru/currency_base/daily/?date_req=" & ДЕНЬ & "%2F" & Месяц & "%2F" & ГОД On Error Resume Next Set oHttp = CreateObject("MSXML2.XMLHTTP") If Err.Number <> 0 Then Set oHttp = CreateObject("MSXML.XMLHTTPRequest") On Error GoTo 0 If oHttp Is Nothing Then Exit Function oHttp.Open "GET", Запрос, False oHttp.Send Ответ = UCase(oHttp.responseText) Курс = CCur(Mid(Ответ, InStr(InStr(1, Ответ, "EUR"), Ответ, "</TD></TR>") - 7, 7)) Set oHttp = Nothing КурсЕвро = Курс End Function
[/vba] Сейчас мне ковыряться, к сожалению, некогда… Может быть кто-то из знамоков посмотрит?Alex_ST
С уважением, Алексей MS Excel 2003 - the best!!!
Сообщение отредактировал Alex_ST - Понедельник, 25.06.2018, 12:27
Function КурсЕвро(Optional ByVal Дата) As Currency ' запрос курса Евро с сайта ЦБ РФ '--------------------------------------------------------------------------------------- ' Procedure : КурсЕвро ' Author : Основа - Pavel55, коррекция - Alex_ST: 2010-01-28 ' URL : http://www.planetaexcel.ru/forum.php?thread_id=6870&page_forum=2&allnum_forum=34 ' Date : 28.01.2010 ' Purpose : Запрос курса Евро, установленного ЦБР на заданную дату ' Notes : По умолчанию - текущая дата '--------------------------------------------------------------------------------------- Dim Запрос$, Ответ$, Курс$ Dim oHttp As Object Dim ДЕНЬ$, Месяц$, ГОД$ Application.Volatile If IsMissing(Дата) Then Дата = Date If Not IsDate(Дата) Then Дата = CDate(Дата) ДЕНЬ = Format(Дата, "dd"): Месяц = Format(Дата, "mm"): ГОД = Format(Дата, "yyyy") ' Запрос = "http://cbr.ru/currency_base/daily.aspx?C_month=" & Месяц & "&C_year=" & ГОД & "&date_req=" & ДЕНЬ & "%2F" & Месяц & "%2F" & ГОД Запрос = "http://cbr.ru/currency_base/daily/?date_req=" & ДЕНЬ & "%2F" & Месяц & "%2F" & ГОД On Error Resume Next Set oHttp = CreateObject("MSXML2.XMLHTTP") If Err.Number <> 0 Then Set oHttp = CreateObject("MSXML.XMLHTTPRequest") On Error GoTo 0 If oHttp Is Nothing Then Exit Function oHttp.Open "GET", Запрос, False oHttp.Send Ответ = UCase(oHttp.responseText) Курс = CCur(Mid(Ответ, InStr(InStr(1, Ответ, "EUR"), Ответ, "</TR>") - 18, 7)) Set oHttp = Nothing КурсЕвро = Курс End Function
[/vba]
В "</TD></TR>" перенос строк видимо появился. Вот так работает: [vba]
Function КурсЕвро(Optional ByVal Дата) As Currency ' запрос курса Евро с сайта ЦБ РФ '--------------------------------------------------------------------------------------- ' Procedure : КурсЕвро ' Author : Основа - Pavel55, коррекция - Alex_ST: 2010-01-28 ' URL : http://www.planetaexcel.ru/forum.php?thread_id=6870&page_forum=2&allnum_forum=34 ' Date : 28.01.2010 ' Purpose : Запрос курса Евро, установленного ЦБР на заданную дату ' Notes : По умолчанию - текущая дата '--------------------------------------------------------------------------------------- Dim Запрос$, Ответ$, Курс$ Dim oHttp As Object Dim ДЕНЬ$, Месяц$, ГОД$ Application.Volatile If IsMissing(Дата) Then Дата = Date If Not IsDate(Дата) Then Дата = CDate(Дата) ДЕНЬ = Format(Дата, "dd"): Месяц = Format(Дата, "mm"): ГОД = Format(Дата, "yyyy") ' Запрос = "http://cbr.ru/currency_base/daily.aspx?C_month=" & Месяц & "&C_year=" & ГОД & "&date_req=" & ДЕНЬ & "%2F" & Месяц & "%2F" & ГОД Запрос = "http://cbr.ru/currency_base/daily/?date_req=" & ДЕНЬ & "%2F" & Месяц & "%2F" & ГОД On Error Resume Next Set oHttp = CreateObject("MSXML2.XMLHTTP") If Err.Number <> 0 Then Set oHttp = CreateObject("MSXML.XMLHTTPRequest") On Error GoTo 0 If oHttp Is Nothing Then Exit Function oHttp.Open "GET", Запрос, False oHttp.Send Ответ = UCase(oHttp.responseText) Курс = CCur(Mid(Ответ, InStr(InStr(1, Ответ, "EUR"), Ответ, "</TR>") - 18, 7)) Set oHttp = Nothing КурсЕвро = Курс End Function
Вход
Регистрация
Напомнить пароль
Автосумма
Часто используемые
ВПР
ЕСЛИ
СУММЕСЛИ
Финансовые
Логические
Текстовые
Даты и времени 
Ссылки и массивы 
Математические
Другие функции
Проверка свойств и значений
Баз данных
Математические
Обработки массивов
Обработки строк
Преобразования типов данных 
Загрузки данных
Работы с файлами
Обработки системных параметров
Обработки цвета
Работы с датами и временем
Преобразования в системы счисления
Финансовые
