Function МетЦБР#(Optional Code% = 2, Optional dDate As Date) Dim d As Object, ddate1 As Date: Set d = CreateObject("MSXML2.DOMDocument.4.0") dDate = IIf(dDate, dDate, Date): ddate1 = Application.EDate(dDate, -1): d.async = 0 d.Load ("http://www.cbr.ru/scripts/xml_metall.asp?date_req1=" & ddate1 & "&date_req2=" & dDate) МетЦБР= CDbl(d.SelectSingleNode("*/Record[@Code='" & Code & "'][last()]/Buy").Text) Set d = Nothing End Function
[/vba]
переписал МетЦБР. Теперь работает как надо [vba]
Код
Function МетЦБР#(Optional Code% = 2, Optional dDate As Date) Dim d As Object, ddate1 As Date: Set d = CreateObject("MSXML2.DOMDocument.4.0") dDate = IIf(dDate, dDate, Date): ddate1 = Application.EDate(dDate, -1): d.async = 0 d.Load ("http://www.cbr.ru/scripts/xml_metall.asp?date_req1=" & ddate1 & "&date_req2=" & dDate) МетЦБР= CDbl(d.SelectSingleNode("*/Record[@Code='" & Code & "'][last()]/Buy").Text) Set d = Nothing End Function
Option Explicit Private Declare Function DeleteUrlCacheEntry& Lib "wininet" (ByVal lpszUrlName$) Function МетЦБР2#(code) Application.Volatile False Dim oHTML As HTMLDocument, oDoc As HTMLDocument, elem As HTMLBaseElement, url$, n%, str$, diff#: Set oHTML = New HTMLDocument url = "http://cbr.ru/" DeleteUrlCacheEntry (url) Set oDoc = oHTML.createDocumentFromUrl(url, "") Do DoEvents Loop Until oDoc.readyState = "complete" oHTML.body.innerHTML = oDoc.getElementById("widget_metal").innerHTML Set oDoc = Nothing n = InStr(1, "_auagptpg", LCase(code)) / 2 - 1 + Val(code) Set elem = oHTML.getElementsByTagName("span")(n) With oHTML.getElementsByTagName("i") If Not .Item(n + 1) Is Nothing Then diff = CDbl(.Item(n + 1).Title) End With МетЦБР2 = CDbl(elem.innerText) - diff 'With Application.Caller ' If Not .Comment Is Nothing Then .Comment.Delete ' str = oHTML.getElementsByTagName("ins")(n).ParentNode.innerText ' str = str & CStr(CDate(Mid(Replace(oHTML.LastModified, "/", "/" & Left(oHTML.LastModified, 3)), 7, 10))) ' .AddComment str & Right(oHTML.LastModified, 9) 'End With Set elem = Nothing Set oHTML = Nothing End Function
[/vba] Если при вычислении этой функции появляется окошко c предупреждением о безопасности, то нужно внести cbr.ru в доверенные узлы: пуск->выполнить->Inetcpl.cpl->безопасность->надежные узлы->узлы->убрать галочку, ввести cbr.ru->добавить->закрыть->ОК или пуск->выполнить->Inetcpl.cpl->безопасность->местная интрасеть->узлы->дополнительно->убрать галочку, ввести cbr.ru->добавить->закрыть->ОК->ОК
Option Explicit Private Declare Function DeleteUrlCacheEntry& Lib "wininet" (ByVal lpszUrlName$) Function МетЦБР2#(code) Application.Volatile False Dim oHTML As HTMLDocument, oDoc As HTMLDocument, elem As HTMLBaseElement, url$, n%, str$, diff#: Set oHTML = New HTMLDocument url = "http://cbr.ru/" DeleteUrlCacheEntry (url) Set oDoc = oHTML.createDocumentFromUrl(url, "") Do DoEvents Loop Until oDoc.readyState = "complete" oHTML.body.innerHTML = oDoc.getElementById("widget_metal").innerHTML Set oDoc = Nothing n = InStr(1, "_auagptpg", LCase(code)) / 2 - 1 + Val(code) Set elem = oHTML.getElementsByTagName("span")(n) With oHTML.getElementsByTagName("i") If Not .Item(n + 1) Is Nothing Then diff = CDbl(.Item(n + 1).Title) End With МетЦБР2 = CDbl(elem.innerText) - diff 'With Application.Caller ' If Not .Comment Is Nothing Then .Comment.Delete ' str = oHTML.getElementsByTagName("ins")(n).ParentNode.innerText ' str = str & CStr(CDate(Mid(Replace(oHTML.LastModified, "/", "/" & Left(oHTML.LastModified, 3)), 7, 10))) ' .AddComment str & Right(oHTML.LastModified, 9) 'End With Set elem = Nothing Set oHTML = Nothing End Function
[/vba] Если при вычислении этой функции появляется окошко c предупреждением о безопасности, то нужно внести cbr.ru в доверенные узлы: пуск->выполнить->Inetcpl.cpl->безопасность->надежные узлы->узлы->убрать галочку, ввести cbr.ru->добавить->закрыть->ОК или пуск->выполнить->Inetcpl.cpl->безопасность->местная интрасеть->узлы->дополнительно->убрать галочку, ввести cbr.ru->добавить->закрыть->ОК->ОКkrosav4ig
ну с валютами все намного проще. ЦБ сам выдает действующий курс на запрашиваемую дату, а с металлами он этого делать не хочет кстати вот переписанная мной функция, которая делает то же самое, что и GetRate, только в случае ошибки она возвращает #ЗНАЧ [vba]
Код
Function ЦБР#(Optional Curr$, Optional dDate As Date) Dim d As Object, date_req$ Set d = CreateObject("msxml.DOMDocument") If Not CBool(Len(Curr)) Then Curr = "USD" date_req = "?date_req=" & IIf(dDate, dDate, Date) d.async = 0: d.Load ("http://www.cbr.ru/scripts/XML_daily.asp" & date_req) With d.SelectSingleNode("*/Valute[CharCode='" & UCase(Curr) & "']") ЦБР = CDbl(.ChildNodes(4).Text) / Val(.ChildNodes(2).Text) End With Set d = Nothing End Function
[/vba] 1 атрибут- буквенный код валюты, если не указан - по умолчанию "USD" 2 атрибут -дата (как в МетЦБР), если не указана - по умолчанию текущая системная дата
есть мысля по поводу исправления МетЦБР2, если после 14:00 мысля подтвердится, выложу исправленный код
ну с валютами все намного проще. ЦБ сам выдает действующий курс на запрашиваемую дату, а с металлами он этого делать не хочет кстати вот переписанная мной функция, которая делает то же самое, что и GetRate, только в случае ошибки она возвращает #ЗНАЧ [vba]
Код
Function ЦБР#(Optional Curr$, Optional dDate As Date) Dim d As Object, date_req$ Set d = CreateObject("msxml.DOMDocument") If Not CBool(Len(Curr)) Then Curr = "USD" date_req = "?date_req=" & IIf(dDate, dDate, Date) d.async = 0: d.Load ("http://www.cbr.ru/scripts/XML_daily.asp" & date_req) With d.SelectSingleNode("*/Valute[CharCode='" & UCase(Curr) & "']") ЦБР = CDbl(.ChildNodes(4).Text) / Val(.ChildNodes(2).Text) End With Set d = Nothing End Function
[/vba] 1 атрибут- буквенный код валюты, если не указан - по умолчанию "USD" 2 атрибут -дата (как в МетЦБР), если не указана - по умолчанию текущая системная дата
есть мысля по поводу исправления МетЦБР2, если после 14:00 мысля подтвердится, выложу исправленный кодkrosav4ig
я правильно понял, что в пятницу ЦБ устанавливает курс, который вступает в силу с субботы и действует по понедельник включительно? и по поводу праздников. К примеру тут написано
Цитата
1, 2, 3, 4, 5, 6 и 8 января — Новогодние каникулы; 7 января — Рождество Христово; 9 января — выходной;
это означает, что 31 декабря устанавливается курс, который вступает в силу 1 янв и действует по 12 янв включительно (1-9 янв нерабочие дни, 10 янв-суббота)?
я правильно понял, что в пятницу ЦБ устанавливает курс, который вступает в силу с субботы и действует по понедельник включительно? и по поводу праздников. К примеру тут написано
Цитата
1, 2, 3, 4, 5, 6 и 8 января — Новогодние каникулы; 7 января — Рождество Христово; 9 января — выходной;
это означает, что 31 декабря устанавливается курс, который вступает в силу 1 янв и действует по 12 янв включительно (1-9 янв нерабочие дни, 10 янв-суббота)?krosav4ig
Wander, а обязательно ячейки именно объединять? Может вам такой вариант подойдет? [vba]
Код
Sub JoinVal() Dim rng As Range, cell As Range, wsh As Worksheet 10 On Error GoTo err 20 With Application 30 .ScreenUpdating = 0: .EnableEvents = 0 40 Set wsh = ThisWorkbook.Worksheets("Лист1") 50 Set rng = Intersect(wsh.UsedRange, wsh.[A:A]) 60 For Each cell In rng.Cells 70 cell.Value = Trim(Join(.Index(wsh.Range(cell, cell.Offset(, _ 2)).Value, 1, 0), " ")) 80 Next 90 wsh.[B:C].EntireColumn.Delete: rng.EntireColumn.AutoFit 100 err: If err.Number Then 110 MsgBox "Ошибка " & err.Number & " (" & err.Description & _ ") в процедуре JoinVal модуля Module1 на строке " & Erl 120 End If 130 .ScreenUpdating = 1: .EnableEvents = 1 140 End With End Sub
[/vba]
Wander, а обязательно ячейки именно объединять? Может вам такой вариант подойдет? [vba]
Код
Sub JoinVal() Dim rng As Range, cell As Range, wsh As Worksheet 10 On Error GoTo err 20 With Application 30 .ScreenUpdating = 0: .EnableEvents = 0 40 Set wsh = ThisWorkbook.Worksheets("Лист1") 50 Set rng = Intersect(wsh.UsedRange, wsh.[A:A]) 60 For Each cell In rng.Cells 70 cell.Value = Trim(Join(.Index(wsh.Range(cell, cell.Offset(, _ 2)).Value, 1, 0), " ")) 80 Next 90 wsh.[B:C].EntireColumn.Delete: rng.EntireColumn.AutoFit 100 err: If err.Number Then 110 MsgBox "Ошибка " & err.Number & " (" & err.Description & _ ") в процедуре JoinVal модуля Module1 на строке " & Erl 120 End If 130 .ScreenUpdating = 1: .EnableEvents = 1 140 End With End Sub
с помощью VBA можно книгу сделать поверх всех окон, но в вашем случае это вряд ли поможет если ваш СКД постоянно забирает фокус. в книге наведите курсор на C1 чтобы сделать поверх всех окон, на A1 чтобы сделать не поверх всех окон
с помощью VBA можно книгу сделать поверх всех окон, но в вашем случае это вряд ли поможет если ваш СКД постоянно забирает фокус. в книге наведите курсор на C1 чтобы сделать поверх всех окон, на A1 чтобы сделать не поверх всех оконkrosav4ig
нарисовал еще одну функцию. возвращает текущую цену на драгметалл с главной страницы ЦБР для работы необходимо подключить Microsoft HTML Object Library [vba]
Код
Private Declare Function DeleteUrlCacheEntry& Lib "wininet" (ByVal lpszUrlName$) Function МетЦБР2#(code) Application.Volatile False Dim oHTML As HTMLDocument, oDoc As HTMLDocument, elem As HTMLBaseElement, url$, n%, str$: Set oHTML = New HTMLDocument url = "http://www.cbr.ru/" DeleteUrlCacheEntry (url) Set oDoc = oHTML.createDocumentFromUrl(url, "") Do DoEvents Loop Until oDoc.readyState = "complete" oHTML.body.innerHTML = oDoc.getElementById("widget_metal").innerHTML Set oDoc = Nothing n = InStr(1, "_auagptpg", LCase(code)) / 2 - 1 + Val(code) Set elem = oHTML.getElementsByTagName("span")(n) МетЦБР2 = CDbl(elem.innerText) 'With Application.Caller ' If Not .Comment Is Nothing Then .Comment.Delete ' str = oHTML.getElementsByTagName("ins")(n).ParentNode.innerText ' str = str & CStr(CDate(Mid(Replace(oHTML.LastModified, "/", "/" & Left(oHTML.LastModified, 3)), 7, 10))) ' .AddComment str & Right(oHTML.LastModified, 9) 'End With Set elem = Nothing Set oHTML = Nothing End Function
[/vba] закомментированные строки кода добавляют в ячейку примечание с названием металла, его буквенным кодом, датой и временем code - числовой или буквенный код металла: золото - 1 или "au", серебро - 2 или "ag", платина -3 или "pt", палладий - 4 или "pd"
нарисовал еще одну функцию. возвращает текущую цену на драгметалл с главной страницы ЦБР для работы необходимо подключить Microsoft HTML Object Library [vba]
Код
Private Declare Function DeleteUrlCacheEntry& Lib "wininet" (ByVal lpszUrlName$) Function МетЦБР2#(code) Application.Volatile False Dim oHTML As HTMLDocument, oDoc As HTMLDocument, elem As HTMLBaseElement, url$, n%, str$: Set oHTML = New HTMLDocument url = "http://www.cbr.ru/" DeleteUrlCacheEntry (url) Set oDoc = oHTML.createDocumentFromUrl(url, "") Do DoEvents Loop Until oDoc.readyState = "complete" oHTML.body.innerHTML = oDoc.getElementById("widget_metal").innerHTML Set oDoc = Nothing n = InStr(1, "_auagptpg", LCase(code)) / 2 - 1 + Val(code) Set elem = oHTML.getElementsByTagName("span")(n) МетЦБР2 = CDbl(elem.innerText) 'With Application.Caller ' If Not .Comment Is Nothing Then .Comment.Delete ' str = oHTML.getElementsByTagName("ins")(n).ParentNode.innerText ' str = str & CStr(CDate(Mid(Replace(oHTML.LastModified, "/", "/" & Left(oHTML.LastModified, 3)), 7, 10))) ' .AddComment str & Right(oHTML.LastModified, 9) 'End With Set elem = Nothing Set oHTML = Nothing End Function
[/vba] закомментированные строки кода добавляют в ячейку примечание с названием металла, его буквенным кодом, датой и временем code - числовой или буквенный код металла: золото - 1 или "au", серебро - 2 или "ag", платина -3 или "pt", палладий - 4 или "pd"krosav4ig
UltrasRW, зачем бегать циклом по элементам, когда есть XPath и нужный элемент можно выбрать одним запросом, и дату ЦБР вполне себе понимает в формате ДД.ММ.ГГГГ forest1333, собственно вот мой вариант функции [vba]
Код
Function МетЦБР#(Optional Code% = 2, Optional dDate As Date, Optional sell% = 0) Dim d As Object: Set d = CreateObject("msxml.DOMDocument") dDate = IIf(dDate, dDate, Date): d.async = 0 d.Load ("http://www.cbr.ru/scripts/xml_metall.asp?date_req1=" & dDate & "&date_req2=" & dDate) МетЦБР = CDbl(d.SelectSingleNode("*/Record[@Code='" & Code & "']").ChildNodes(Abs(sell)).Text) Set d = Nothing End Function
[/vba] у функции 3 необязательных атрибута Первый: Код металла (1-золото,2-серебро,3-платина,4-палладий), если параметр не указан, то по умолчанию берется 2 Второй: дата в текстовом формате или ссылка на ячейку с датой в числовом формате. если параметр не указан, то по умолчанию берется текущая СИСТЕМНАЯ дата (дата, установленная в компьютере, может не совпадать с фактической) в качестве разделителей между числами дня, месяца и года может использоваться любой символ из " " , "/" , "." , "-" , "," , запись даты в формате "1 янв 14" и "1 января 2014" тоже корректно распознаются По моему курсы на покупку и продажу у ЦБР одинаковые, но на всякий случай сделал третий атрибут: тип курса банка- 0-покупка, 1-продажа, если параметр не указан, то по умолчанию берется 0 формула
Код
=МетЦБР()
вернет текущий курс банка на покупку серебра.
UltrasRW, зачем бегать циклом по элементам, когда есть XPath и нужный элемент можно выбрать одним запросом, и дату ЦБР вполне себе понимает в формате ДД.ММ.ГГГГ forest1333, собственно вот мой вариант функции [vba]
Код
Function МетЦБР#(Optional Code% = 2, Optional dDate As Date, Optional sell% = 0) Dim d As Object: Set d = CreateObject("msxml.DOMDocument") dDate = IIf(dDate, dDate, Date): d.async = 0 d.Load ("http://www.cbr.ru/scripts/xml_metall.asp?date_req1=" & dDate & "&date_req2=" & dDate) МетЦБР = CDbl(d.SelectSingleNode("*/Record[@Code='" & Code & "']").ChildNodes(Abs(sell)).Text) Set d = Nothing End Function
[/vba] у функции 3 необязательных атрибута Первый: Код металла (1-золото,2-серебро,3-платина,4-палладий), если параметр не указан, то по умолчанию берется 2 Второй: дата в текстовом формате или ссылка на ячейку с датой в числовом формате. если параметр не указан, то по умолчанию берется текущая СИСТЕМНАЯ дата (дата, установленная в компьютере, может не совпадать с фактической) в качестве разделителей между числами дня, месяца и года может использоваться любой символ из " " , "/" , "." , "-" , "," , запись даты в формате "1 янв 14" и "1 января 2014" тоже корректно распознаются По моему курсы на покупку и продажу у ЦБР одинаковые, но на всякий случай сделал третий атрибут: тип курса банка- 0-покупка, 1-продажа, если параметр не указан, то по умолчанию берется 0 формула
Код
=МетЦБР()
вернет текущий курс банка на покупку серебра.krosav4ig
Function ЕЦБ#(ByVal Curr$) Dim d As New DOMDocument Set d = New DOMDocument d.async = 0: d.Load ("http://www.ecb.europa.eu/stats/eurofxref/eurofxref-daily.xml") ЕЦБ = Val(d.SelectSingleNode("//Cube[@currency='" & UCase(Curr) & "']").Attributes(1).Text) Set d = Nothing End Function
[/vba]в ячейку формулу
Код
=ЕЦБ("NZD")
в модуль код [vba]
Код
Function ЕЦБ#(ByVal Curr$) Dim d As New DOMDocument Set d = New DOMDocument d.async = 0: d.Load ("http://www.ecb.europa.eu/stats/eurofxref/eurofxref-daily.xml") ЕЦБ = Val(d.SelectSingleNode("//Cube[@currency='" & UCase(Curr) & "']").Attributes(1).Text) Set d = Nothing End Function
Вход
Регистрация
Напомнить пароль
Автосумма
Часто используемые
ВПР
ЕСЛИ
СУММЕСЛИ
Финансовые
Логические
Текстовые
Даты и времени 
Ссылки и массивы 
Математические
Другие функции
Проверка свойств и значений
Баз данных
Математические
Обработки массивов
Обработки строк
Преобразования типов данных 
Загрузки данных
Работы с файлами
Обработки системных параметров
Обработки цвета
Работы с датами и временем
Преобразования в системы счисления
Финансовые
