Мне стало интересно где собака зарыта! немного покопался и вот что удалось узнать. Функции работают правильно и возвращают значение с четырьмя цифрами после запятой, коллапс происходит во время записи данных в ячейку! причем от версии офиса это никак не зависит (проверил на 2003-2007) если быть более конкретно то проблема в этих строках [vba]
[/vba] Насколько я понимаю причиной данного безобразия является то что функции возвращают данные типа Currency предназначенные для денежных вычислений, а при попытке записать эти данные в ячейку эксель как бы понимает что речь идет о деньгах и приводит их к своему (наверное стандартному для него) двузначному формату. Первое что пришло в голову это попробовать изменить формат данных с помощью функции format выглядело это примерно так [vba]
[/vba] Но в этом случае возвращается текстовое значение, а не назначается формат ячейки хотя иногда это может быть и полезно! Вторым очевидным решением было заменить тип данных возвращаемых функцией с Currency на Double в данном случае на первый взгляд все стало работать корректно. PS: да немного опоздал с ответом PSPS: по поводу авто вставки. Запишите макроредактором ваши формулы и потом настройте чтобы макрос вставлял их при добавлении даты
Мне стало интересно где собака зарыта! немного покопался и вот что удалось узнать. Функции работают правильно и возвращают значение с четырьмя цифрами после запятой, коллапс происходит во время записи данных в ячейку! причем от версии офиса это никак не зависит (проверил на 2003-2007) если быть более конкретно то проблема в этих строках [vba]
[/vba] Насколько я понимаю причиной данного безобразия является то что функции возвращают данные типа Currency предназначенные для денежных вычислений, а при попытке записать эти данные в ячейку эксель как бы понимает что речь идет о деньгах и приводит их к своему (наверное стандартному для него) двузначному формату. Первое что пришло в голову это попробовать изменить формат данных с помощью функции format выглядело это примерно так [vba]
[/vba] Но в этом случае возвращается текстовое значение, а не назначается формат ячейки хотя иногда это может быть и полезно! Вторым очевидным решением было заменить тип данных возвращаемых функцией с Currency на Double в данном случае на первый взгляд все стало работать корректно. PS: да немного опоздал с ответом PSPS: по поводу авто вставки. Запишите макроредактором ваши формулы и потом настройте чтобы макрос вставлял их при добавлении датыPoltava
Сообщение отредактировал Poltava - Среда, 10.07.2013, 15:54
Может это от винды зависит? У меня на работе ХР, при этом даже меняя системные настройки для денежных единиц, и параллельно настройки экселя на вывод 4 цифр после запятой, всё равно округляет до двух знаков и после дополняет нулями до четырёх
ЗЫ Дома проверю на семёрке
Может это от винды зависит? У меня на работе ХР, при этом даже меняя системные настройки для денежных единиц, и параллельно настройки экселя на вывод 4 цифр после запятой, всё равно округляет до двух знаков и после дополняет нулями до четырёх
Private Function Ex_Rate_USD(Optional ByVal Дата) As Currency
[/vba]на[vba]
Код
Private Function Ex_Rate_USD(Optional ByVal Дата) As Single
[/vba]И будет Вам щастье.
Ну, вообще-то переменная, определённая As Currency, может принимать значения от -922337203685477,5808 до 922337203685477,5807 Так что это тут ни при чём. Тем более, что у меня всё работает правильно. Скорее всего всё-таки от версии Excel'я зависит.
Private Function Ex_Rate_USD(Optional ByVal Дата) As Currency
[/vba]на[vba]
Код
Private Function Ex_Rate_USD(Optional ByVal Дата) As Single
[/vba]И будет Вам щастье.
Ну, вообще-то переменная, определённая As Currency, может принимать значения от -922337203685477,5808 до 922337203685477,5807 Так что это тут ни при чём. Тем более, что у меня всё работает правильно. Скорее всего всё-таки от версии Excel'я зависит.Alex_ST
С уважением, Алексей MS Excel 2003 - the best!!!
Сообщение отредактировал Alex_ST - Среда, 10.07.2013, 16:46
Да, я в курсе, и простая трассировка показывает что функции возвращают именно 4 знака после запятой, но вот при присвоении значения конкретной ячейке эксель почему-то округляет до двух знаков после запятой. Со значениями в формате Single\Double этого не происходит.
Да, я в курсе, и простая трассировка показывает что функции возвращают именно 4 знака после запятой, но вот при присвоении значения конкретной ячейке эксель почему-то округляет до двух знаков после запятой. Со значениями в формате Single\Double этого не происходит.M73568
Недавно самому потребовалась обновлялка курсов валют, данную тему не видел, поэтому изобретал велосипед. Обновление происходит не по каждой дате в отдельности, а сразу диапазоном, если нужны курсы за год или за несколько лет, позволяет сэкономить трафик. Можно загрузить/обновить данные или дополнить с последней известной до завтрешней даты. Список курсов валют загружается на отдельный лист, нужный курс можно потом проВПРить.
Если чего накосячил - сообщите
Недавно самому потребовалась обновлялка курсов валют, данную тему не видел, поэтому изобретал велосипед. Обновление происходит не по каждой дате в отдельности, а сразу диапазоном, если нужны курсы за год или за несколько лет, позволяет сэкономить трафик. Можно загрузить/обновить данные или дополнить с последней известной до завтрешней даты. Список курсов валют загружается на отдельный лист, нужный курс можно потом проВПРить.
Суки-сисадмины умудряются просто удалять программные модули из Excel-файлов, а архивы при попытке загрузки кричат: "Файл заражён! Загрузка запрещена"
Суки-сисадмины умудряются просто удалять программные модули из Excel-файлов, а архивы при попытке загрузки кричат: "Файл заражён! Загрузка запрещена"Alex_ST
Ну тогда могу предложить опубликовать здесь код, если файл скачивается, а макросов в нем нет: [vba]
Код
Option Explicit
Sub GetRateUSDandEUR(Date1 As Date, Date2 As Date, outRange As Range) 'макрос загрузки курсов USD и EUR с сайта www.cbr.ru 'автор Михаил Ч. (MCH), август 2013 Dim i&, len1&, len2&, url_addr$, url_request1$, url_request2$, outArr() Dim xmldoc1, xmldoc2, nodeList1, nodeList2, xmlNode1, xmlNode2
On Error Resume Next Set xmldoc1 = CreateObject("Msxml.DOMDocument"): xmldoc1.async = False Set xmldoc2 = CreateObject("Msxml.DOMDocument"): xmldoc2.async = False
If xmldoc1.Load(url_request1) <> True Or xmldoc2.Load(url_request2) <> True Then Exit Sub 'Запрос к серверу ЦБР
Set nodeList1 = xmldoc1.SelectNodes("*/Record"): len1 = nodeList1.Length Set nodeList2 = xmldoc2.SelectNodes("*/Record"): len2 = nodeList2.Length If len1 <> len2 Or len1 = 0 Then Exit Sub
ReDim outArr(1 To len1, 1 To 3) For i = 0 To len1 Set xmlNode1 = nodeList1.Item(i).CloneNode(True) Set xmlNode2 = nodeList2.Item(i).CloneNode(True) outArr(i + 1, 1) = CDate(xmlNode1.Attributes(0).Text) outArr(i + 1, 2) = CDbl(xmlNode1.ChildNodes(1).Text) outArr(i + 1, 3) = CDbl(xmlNode2.ChildNodes(1).Text) 'Debug.Print xmlNode1.Attributes(0).Text, xmlNode1.childNodes(1).Text, xmlNode2.childNodes(1).Text Next i
outRange.ClearContents outRange.Resize(len1, 3) = outArr End Sub
Sub GetRate() On Error Resume Next GetRateUSDandEUR CDate([Date1]), CDate([Date2]), [outRange] End Sub
Sub GetNewRate() 'дополнить котировки с последней известной до завтрашней даты Dim d1 As Date On Error Resume Next d1 = Application.Max([outRange].Columns(1)) + 1 'узнаем максимально известную дату If d1 = 1 Then d1 = CDate([Date1]) 'если дат нет, то берем Date1 GetRateUSDandEUR d1, Now + 1, [outRange].Resize(1, 1).Offset(Application.Count([outRange].Columns(1)), 0) End Sub
[/vba]
В книге объявлены имена, на которые ссылается макрос: Date1 - начальная дата, Date2 - конечная дата, outRange - диапазон куда производится выгрузка
Ну тогда могу предложить опубликовать здесь код, если файл скачивается, а макросов в нем нет: [vba]
Код
Option Explicit
Sub GetRateUSDandEUR(Date1 As Date, Date2 As Date, outRange As Range) 'макрос загрузки курсов USD и EUR с сайта www.cbr.ru 'автор Михаил Ч. (MCH), август 2013 Dim i&, len1&, len2&, url_addr$, url_request1$, url_request2$, outArr() Dim xmldoc1, xmldoc2, nodeList1, nodeList2, xmlNode1, xmlNode2
On Error Resume Next Set xmldoc1 = CreateObject("Msxml.DOMDocument"): xmldoc1.async = False Set xmldoc2 = CreateObject("Msxml.DOMDocument"): xmldoc2.async = False
If xmldoc1.Load(url_request1) <> True Or xmldoc2.Load(url_request2) <> True Then Exit Sub 'Запрос к серверу ЦБР
Set nodeList1 = xmldoc1.SelectNodes("*/Record"): len1 = nodeList1.Length Set nodeList2 = xmldoc2.SelectNodes("*/Record"): len2 = nodeList2.Length If len1 <> len2 Or len1 = 0 Then Exit Sub
ReDim outArr(1 To len1, 1 To 3) For i = 0 To len1 Set xmlNode1 = nodeList1.Item(i).CloneNode(True) Set xmlNode2 = nodeList2.Item(i).CloneNode(True) outArr(i + 1, 1) = CDate(xmlNode1.Attributes(0).Text) outArr(i + 1, 2) = CDbl(xmlNode1.ChildNodes(1).Text) outArr(i + 1, 3) = CDbl(xmlNode2.ChildNodes(1).Text) 'Debug.Print xmlNode1.Attributes(0).Text, xmlNode1.childNodes(1).Text, xmlNode2.childNodes(1).Text Next i
outRange.ClearContents outRange.Resize(len1, 3) = outArr End Sub
Sub GetRate() On Error Resume Next GetRateUSDandEUR CDate([Date1]), CDate([Date2]), [outRange] End Sub
Sub GetNewRate() 'дополнить котировки с последней известной до завтрашней даты Dim d1 As Date On Error Resume Next d1 = Application.Max([outRange].Columns(1)) + 1 'узнаем максимально известную дату If d1 = 1 Then d1 = CDate([Date1]) 'если дат нет, то берем Date1 GetRateUSDandEUR d1, Now + 1, [outRange].Resize(1, 1).Offset(Application.Count([outRange].Columns(1)), 0) End Sub
[/vba]
В книге объявлены имена, на которые ссылается макрос: Date1 - начальная дата, Date2 - конечная дата, outRange - диапазон куда производится выгрузкаMCH
Сообщение отредактировал MCH - Вторник, 27.08.2013, 17:50
Из дома качнул на Яндекс.Диск Его наши коцать не умеют. Попробую на работе найти время, не закрутиться, не забыть и посмотреть (видите, сколько условий должно совпасть?)
Из дома качнул на Яндекс.Диск Его наши коцать не умеют. Попробую на работе найти время, не закрутиться, не забыть и посмотреть (видите, сколько условий должно совпасть?) Alex_ST
Вариант функций через XML запрос с сайта ЦБР [vba]
Код
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
[/vba] [vba]
Код
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
[/vba]
Вариант функций через XML запрос с сайта ЦБР [vba]
Код
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
[/vba] [vba]
Код
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
На работе жуткий завал... Спасибо, Миша, что напомнил о моём намерении проверить. Извини за задержку. Проверил дома. ОТЛИЧНО и коротко. Только я не понял, откуда берётся код валюты для бакса [@ID='R01235'] , а для евро [@ID='R01239']? Это какое-то табличное значение, наверное? Тогда это - единственный недостаток твоего кода по сравнению с моим: нельзя сделать универсальную функцию, запрашивающую курс любой валюты по её стандартному условному обозначению. Я не помню, кажется на старой Планете выкладывал такую универсальную функцию. (выдрал As Is из своего Personal.xls вместе с комментариями и пояснениями, оставленными для себя когда разбирал код уважаемого ZVI)
[vba]
Код
Function КурсЦБР(Optional Код_Валюты = "USD", Optional ByVal Дата) As Currency ' запрос курса любой валюты с сайта ЦБ РФ '--------------------------------------------------------------------------------------- ' Procedure : КурсЦБР ' Author : Основа - ZVI:2008-10-31, коррекция - Alex_ST: 2010-01-28 ' URL : http://www.planetaexcel.ru/forum.php?thread_id=3816 ' Date : 28.01.2010 ' Purpose : Определение курса валют, установленного ЦБР на заданную дату [по умолчанию - текущая дата] ' Notes : Валюта - любая [по умолчанию - доллар США] из публикуемых на сайте ЦБРФ ' http://cbr.ru/currency_base/daily.aspx ' Вместо кода валюты можно вводить уникальную часть её названия: ' (вместо "BUR" можно ввести "Белорусских рублей" или "белорус") ' Примеры вызова в формуле ячейки: ' =КурсЦБР()или =КурсЦБР("USD") или =КурсЦБР("сШа") - курс USD для текущей даты ' =КурсЦБР(;"2008-10-30")или =КурсЦБР(;"2008.10.30") или =КурсЦБР("сШа") - курс USD для даты 2008.10.30 ' Аналогично: ' =КурсЦБР("EUR") или =КурсЦБР("еВрО") - курс EUR для текущей даты ' =КурсЦБР("EUR";"2008/10/30") или =КурсЦБР("EUR";ДАТА(2008;10;30)) '--------------------------------------------------------------------------------------- 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" & ГОД On Error Resume Next Set oHttp = CreateObject("MSXML2.XMLHTTP") If Err <> 0 Then Set oHttp = CreateObject("MSXML.XMLHTTPRequest") If oHttp Is Nothing Then Exit Function oHttp.Open "GET", Запрос, False oHttp.Send Ответ = UCase(oHttp.responseText) 'В HTML-коде, получаемом по запросу от сервера ЦБРФ, строка таблицы для, например, Евро выглядит как: '(с соблюдением переноса строк) '<tr><td align=""right"">978</td> -- начало новой строки <tr>; начало первой ячейки с выравниванием "направо" <td align=""right"">; цифровой код валюты 978 ; конец первой ячейки </td> '<td align=""left""> EUR</td> -- начало второй ячейки с выравниванием "налево" <td align=""left"">; два неразрывных пробела (отступ текста от левого края второй ячейки) буквенный код валюты EUR ; конец второй ячейки </td> '<td align=""right"">1</td> -- начало третьей ячейки с выравниванием "направо" <td align=""right"">; кол-во единиц 1 ; конец третьей ячейки </td> '<td> Евро</td> -- начало четвертой ячейки <td> ; два неразрывных пробела (отступ текста от левого края ячейки) название валюты Евро ; конец четвертой ячейки </td> '<td align=""right"">42,5905</td></tr> -- начало пятой ячейки с выравниванием "направо" <td align=""right"">; курс 42,5905 ;конец ячейки </td> и строки </tr> Курс = CCur(Mid(Ответ, InStr(InStr(1, Ответ, UCase(Код_Валюты)), Ответ, "</TD></TR>") - 7, 7)) ' найти в стринге-ответе (HTML-коде) позицию слова UCase(Код_Валюты), например, "USD" ' начиная с этой позиции найти позицию конца строки - HTML-тэги "</td></tr>" ' отступить от найденной позиции на -7 символов и взять от этой позиции 7 символов - это и есть курс Set oHttp = Nothing '------------------------------------------------------------------------------- 'считываем значение ключа реестра HKEY_CURRENT_USER\Control Panel\International\\sMonDecimalSep 'чтобы узнать какой знак является разделителем целой и дробной части на данном компьютере '(Панель управления - Язык и региональные стандарты - Настройка - Денежная единица - Разделитель целой и дробной части) ' If CreateObject("WScript.Shell").RegRead("HKEY_CURRENT_USER\Control Panel\International\\sMonDecimalSep") = "." Then Курс = Replace(Курс, ",", ".") '------------------------------------------------------------------------------- КурсЦБР = Курс End Function
Нельзя ли как-то в твоём методе вычислять нужное значение [@ID='R0????'] по коду валюты?
На работе жуткий завал... Спасибо, Миша, что напомнил о моём намерении проверить. Извини за задержку. Проверил дома. ОТЛИЧНО и коротко. Только я не понял, откуда берётся код валюты для бакса [@ID='R01235'] , а для евро [@ID='R01239']? Это какое-то табличное значение, наверное? Тогда это - единственный недостаток твоего кода по сравнению с моим: нельзя сделать универсальную функцию, запрашивающую курс любой валюты по её стандартному условному обозначению. Я не помню, кажется на старой Планете выкладывал такую универсальную функцию. (выдрал As Is из своего Personal.xls вместе с комментариями и пояснениями, оставленными для себя когда разбирал код уважаемого ZVI)
[vba]
Код
Function КурсЦБР(Optional Код_Валюты = "USD", Optional ByVal Дата) As Currency ' запрос курса любой валюты с сайта ЦБ РФ '--------------------------------------------------------------------------------------- ' Procedure : КурсЦБР ' Author : Основа - ZVI:2008-10-31, коррекция - Alex_ST: 2010-01-28 ' URL : http://www.planetaexcel.ru/forum.php?thread_id=3816 ' Date : 28.01.2010 ' Purpose : Определение курса валют, установленного ЦБР на заданную дату [по умолчанию - текущая дата] ' Notes : Валюта - любая [по умолчанию - доллар США] из публикуемых на сайте ЦБРФ ' http://cbr.ru/currency_base/daily.aspx ' Вместо кода валюты можно вводить уникальную часть её названия: ' (вместо "BUR" можно ввести "Белорусских рублей" или "белорус") ' Примеры вызова в формуле ячейки: ' =КурсЦБР()или =КурсЦБР("USD") или =КурсЦБР("сШа") - курс USD для текущей даты ' =КурсЦБР(;"2008-10-30")или =КурсЦБР(;"2008.10.30") или =КурсЦБР("сШа") - курс USD для даты 2008.10.30 ' Аналогично: ' =КурсЦБР("EUR") или =КурсЦБР("еВрО") - курс EUR для текущей даты ' =КурсЦБР("EUR";"2008/10/30") или =КурсЦБР("EUR";ДАТА(2008;10;30)) '--------------------------------------------------------------------------------------- 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" & ГОД On Error Resume Next Set oHttp = CreateObject("MSXML2.XMLHTTP") If Err <> 0 Then Set oHttp = CreateObject("MSXML.XMLHTTPRequest") If oHttp Is Nothing Then Exit Function oHttp.Open "GET", Запрос, False oHttp.Send Ответ = UCase(oHttp.responseText) 'В HTML-коде, получаемом по запросу от сервера ЦБРФ, строка таблицы для, например, Евро выглядит как: '(с соблюдением переноса строк) '<tr><td align=""right"">978</td> -- начало новой строки <tr>; начало первой ячейки с выравниванием "направо" <td align=""right"">; цифровой код валюты 978 ; конец первой ячейки </td> '<td align=""left""> EUR</td> -- начало второй ячейки с выравниванием "налево" <td align=""left"">; два неразрывных пробела (отступ текста от левого края второй ячейки) буквенный код валюты EUR ; конец второй ячейки </td> '<td align=""right"">1</td> -- начало третьей ячейки с выравниванием "направо" <td align=""right"">; кол-во единиц 1 ; конец третьей ячейки </td> '<td> Евро</td> -- начало четвертой ячейки <td> ; два неразрывных пробела (отступ текста от левого края ячейки) название валюты Евро ; конец четвертой ячейки </td> '<td align=""right"">42,5905</td></tr> -- начало пятой ячейки с выравниванием "направо" <td align=""right"">; курс 42,5905 ;конец ячейки </td> и строки </tr> Курс = CCur(Mid(Ответ, InStr(InStr(1, Ответ, UCase(Код_Валюты)), Ответ, "</TD></TR>") - 7, 7)) ' найти в стринге-ответе (HTML-коде) позицию слова UCase(Код_Валюты), например, "USD" ' начиная с этой позиции найти позицию конца строки - HTML-тэги "</td></tr>" ' отступить от найденной позиции на -7 символов и взять от этой позиции 7 символов - это и есть курс Set oHttp = Nothing '------------------------------------------------------------------------------- 'считываем значение ключа реестра HKEY_CURRENT_USER\Control Panel\International\\sMonDecimalSep 'чтобы узнать какой знак является разделителем целой и дробной части на данном компьютере '(Панель управления - Язык и региональные стандарты - Настройка - Денежная единица - Разделитель целой и дробной части) ' If CreateObject("WScript.Shell").RegRead("HKEY_CURRENT_USER\Control Panel\International\\sMonDecimalSep") = "." Then Курс = Replace(Курс, ",", ".") '------------------------------------------------------------------------------- КурсЦБР = Курс End Function
Я как раз заинтересовалься вариантом через XML, подсмотрев код Игоря, только у него там есть лишние строчки, совершенно не нужные в коде (о чем я там и написал). Хорошее описание по объектной модели XML есть здесь: http://www.script-coding.com/XMLDOMscripts.html
Я как раз заинтересовалься вариантом через XML, подсмотрев код Игоря, только у него там есть лишние строчки, совершенно не нужные в коде (о чем я там и написал). Хорошее описание по объектной модели XML есть здесь: http://www.script-coding.com/XMLDOMscripts.html
Немного сокращенная функция на базе варианта EducatedFool (кстати, он ее не сам писал, а где-то взял): [vba]
Код
Function GetRate(ByVal CurrencyName As String, Optional ByVal RateDate As Date) As Double Dim i&, xmldoc, nodeList, xmlNode On Error Resume Next If Len(CurrencyName) <> 3 Then Exit Function Else CurrencyName = UCase(CurrencyName) If RateDate = 0 Then RateDate = Date Set xmldoc = CreateObject("Msxml.DOMDocument"): xmldoc.async = False If Not xmldoc.Load("http://www.cbr.ru/scripts/XML_daily.asp?date_req=" & Format(RateDate, "dd\/mm\/yyyy")) Then Exit Function Set nodeList = xmldoc.selectNodes("//Valute") For i = 0 To nodeList.Length - 1 Set xmlNode = nodeList.Item(i) If xmlNode.childNodes(1).Text = CurrencyName Then GetRate = CDbl(xmlNode.childNodes(4).Text) / Val(xmlNode.childNodes(2).Text) Exit Function End If Next i End Function
[/vba] Можно использовать в виде
Код
=GetRate("USD")
или
Код
=GetRate("eur";"29.08.2013")
Немного сокращенная функция на базе варианта EducatedFool (кстати, он ее не сам писал, а где-то взял): [vba]
Код
Function GetRate(ByVal CurrencyName As String, Optional ByVal RateDate As Date) As Double Dim i&, xmldoc, nodeList, xmlNode On Error Resume Next If Len(CurrencyName) <> 3 Then Exit Function Else CurrencyName = UCase(CurrencyName) If RateDate = 0 Then RateDate = Date Set xmldoc = CreateObject("Msxml.DOMDocument"): xmldoc.async = False If Not xmldoc.Load("http://www.cbr.ru/scripts/XML_daily.asp?date_req=" & Format(RateDate, "dd\/mm\/yyyy")) Then Exit Function Set nodeList = xmldoc.selectNodes("//Valute") For i = 0 To nodeList.Length - 1 Set xmlNode = nodeList.Item(i) If xmlNode.childNodes(1).Text = CurrencyName Then GetRate = CDbl(xmlNode.childNodes(4).Text) / Val(xmlNode.childNodes(2).Text) Exit Function End If Next i End Function
Отлично, что можно указать вид валюты, т.к. мне нужны USD+EUR+CNY+UAH+UZS. Но есть 2 проблемы: 1. Курс ЦБ многих валют указан за N штук (CNY/UAH - за 10, UZS - за 1000 и т.д.) Как их привести к "единому знаменателю" - 1? 2. Можно ли адаптировать UDF для Сбербанка (http://sberbank.ru/kostroma/ru/valkprev/archive_3/) Использовать "Данные - Импорт из Интернета" + ВПР не удобно, составить запрос на конкретное число нельзя.
Help!
Отлично, что можно указать вид валюты, т.к. мне нужны USD+EUR+CNY+UAH+UZS. Но есть 2 проблемы: 1. Курс ЦБ многих валют указан за N штук (CNY/UAH - за 10, UZS - за 1000 и т.д.) Как их привести к "единому знаменателю" - 1? 2. Можно ли адаптировать UDF для Сбербанка (http://sberbank.ru/kostroma/ru/valkprev/archive_3/) Использовать "Данные - Импорт из Интернета" + ВПР не удобно, составить запрос на конкретное число нельзя.