курс доллара и евро

Дата: Четверг, 03.05.2012, 13:24 | Сообщение № 1

Группа: Проверенные

Ранг: Форумчанин

Сообщений: 192

Репутация: 6 ±

Замечаний: 0% ±

все описано в файле: номер 1.

К сообщению приложен файл: i_i-.xlsm (26.3 Kb)

Сообщение отредактировал anger47 - Четверг, 03.05.2012, 13:24

Дата: Четверг, 03.05.2012, 13:24 | Сообщение № 2

Группа: Проверенные

Ранг: Форумчанин

Сообщений: 192

Репутация: 6 ±

Замечаний: 0% ±

а вот файл номер 2

К сообщению приложен файл: dollar.rar (39.4 Kb)

Сообщение отредактировал anger47 - Четверг, 03.05.2012, 13:26

Дата: Четверг, 03.05.2012, 13:34 | Сообщение № 3

Группа: Друзья

Ранг: Участник клуба

Сообщений: 3206

Репутация: 609 ±

Замечаний: 0% ±

2003

А где этот самый "другой файл" , на который вы ссылаетесь в своей хотелке?
И как, интересно, должен выглядеть календарь "как у меня" если в Вашем файле есть только 1 календарь, который Вас, похоже, не устраивает?
И с какого сайта Вы хотите получать курсы валют? Похоже, что с НБУ. Ну так поищите в сети соответствующую UDF-ку. Наверняка должно быть полно.

С уважением,
Алексей
MS Excel 2003 - the best!!!

Дата: Четверг, 03.05.2012, 13:40 | Сообщение № 4

Группа: Проверенные

Ранг: Форумчанин

Сообщений: 192

Репутация: 6 ±

Замечаний: 0% ±

Alex_ST, файл не влезал. пока сжал в рар архив.

Quote (Alex_ST)

в Вашем файле есть только 1 календарь, который Вас, похоже, не устраивает?

меня мой устраивает, меня другой не устраивает=)

Quote (Alex_ST)

Ну так поищите в сети соответствующую UDF-ку. Наверняка должно быть полно

искал, но не нашол. вы же не думаете, что я по первому своему желанию к Вам обращаюсь. Если я бы мог переписать сам то зделал бы. Я пробовал, но у меня шла ошибка макроса. На сайте НБУ не реагирует ексель.. тут берет с другого сайта. мне впринцепе пофыг с какого сайта лиш бы информация НБУ. Може я ещё что то не понятно написал пишите я сразу отвечю. я на форуме сижу

Дата: Четверг, 03.05.2012, 16:56 | Сообщение № 5

Группа: Друзья

Ранг: Участник клуба

Сообщений: 3206

Репутация: 609 ±

Замечаний: 0% ±

2003

anger47,
вот, я подпилил UDF-ку.
Теперь ей можно задавать код валюты и дату (опционально)
[vba]

Code

Function Курс_НБУ(sCurr$, Optional ByVal Дата) ' курсы валют к гривне в НБУ
'sCurr - код валюты USD EUR RUB BYR … см. на http://www.bankstore.com.ua/currencyrates/dailyrates/
    Dim sURL$, objHttp As Object, sHtmlCode$
    Dim sDay$, sMonth$, sYear$
    Dim CurrRate!, lPosCurrRate&
    Dim sValue$, QTY%, lPosTdClass&
    Dim sTdClass$, lTbPos&
    '-------------------------------------------------------------------------------
    Application.Volatile
    If IsMissing(Дата) Then Дата = Date
    If Дата = "" Then Курс_НБУ = CVErr(xlErrValue): Exit Function    ' вернуть ошибку #ЗНАЧЕНИЕ
    If Not IsDate(Дата) Then Дата = CDate(Дата)
    Дата = CDate(Дата)
    sDay = Format(Дата, "dd"): sMonth = Format(Дата, "mm"): sYear = Format(Дата, "yyyy")
    sURL = "http://www.bankstore.com.ua/currencyrates/dailyrates/123286/?currency_id=16&year=" & sYear & "&month=" & sMonth & "&day=" & sDay & "&rate_type=0"
    On Error Resume Next
    Set objHttp = CreateObject("MSXML2.XMLHTTP.3.0")
    If Err.Number <> 0 Then
       Err.Clear
       Set objHttp = CreateObject("MSXML2.XMLHTTP")
       If Err.Number <> 0 Then Set objHttp = CreateObject("MSXML.XMLHTTPRequest")
    End If
    If objHttp Is Nothing Then Курс_НБУ = CVErr(xlErrValue): Exit Function   ' вернуть ошибку #ЗНАЧЕНИЕ
    objHttp.Open "GET", sURL, False
    On Error Resume Next
    objHttp.Send
    If Err.Number <> 0 Then Курс_НБУ = CVErr(xlErrValue): Exit Function    ' вернуть ошибку #ЗНАЧЕНИЕ
    On Error GoTo 0
    sHtmlCode = objHttp.responseText
    Set objHttp = Nothing
    On Error Resume Next
    sCurr = UCase(sCurr) ' на всякий случай
    sTdClass = "<td class="""" align=""center"">"
    lPosTdClass = InStr(InStr(1, sHtmlCode, sCurr), sHtmlCode, sTdClass) 'начало текста нужной ячейки
    sValue = Trim(Mid(sHtmlCode, lPosTdClass + Len(sTdClass), InStr(lPosTdClass, sHtmlCode, "</td>") - lPosTdClass - Len(sTdClass)))
    QTY = --(sValue) ' за количество единиц
    sTdClass = "<td class=""rate"">"
    lPosTdClass = InStr(InStr(1, sHtmlCode, sCurr), sHtmlCode, sTdClass) 'начало текста нужной ячейки
    sValue = Trim(Mid(sHtmlCode, lPosTdClass + Len(sTdClass), InStr(lPosTdClass, sHtmlCode, "</td>") - lPosTdClass - Len(sTdClass)))
    CurrRate = CSng(Trim(Replace(sValue, ".", ",")))
    Курс_НБУ = FormatNumber(WorksheetFunction.Round(CurrRate / QTY, 4), 4)
End Function

[/vba]

anger47,
вот, я подпилил UDF-ку.
Теперь ей можно задавать код валюты и дату (опционально)
[vba]

Code

[/vba]Alex_ST

С уважением,
Алексей
MS Excel 2003 - the best!!!

Сообщение отредактировал Alex_ST - Четверг, 03.05.2012, 16:59

Сообщениеanger47,
вот, я подпилил UDF-ку.
Теперь ей можно задавать код валюты и дату (опционально)
[vba]

Code

[/vba]

Автор - Alex_ST
Дата добавления - 03.05.2012 в 16:56

Дата: Четверг, 03.05.2012, 16:58 | Сообщение № 6

Группа: Проверенные

Ранг: Форумчанин

Сообщений: 192

Репутация: 6 ±

Замечаний: 0% ±

шас закину проверю

Дата: Четверг, 03.05.2012, 17:01 | Сообщение № 7

Группа: Друзья

Ранг: Участник клуба

Сообщений: 3206

Репутация: 609 ±

Замечаний: 0% ±

2003

anger47,
я подправил код! Скопируйте ещё раз.

С уважением,
Алексей
MS Excel 2003 - the best!!!

Дата: Четверг, 03.05.2012, 17:10 | Сообщение № 8

Группа: Проверенные

Ранг: Форумчанин

Сообщений: 192

Репутация: 6 ±

Замечаний: 0% ±

Почему ноль?

К сообщению приложен файл: 1536382.xlsm (31.7 Kb)

Дата: Четверг, 03.05.2012, 17:25 | Сообщение № 9

Группа: Друзья

Ранг: Участник клуба

Сообщений: 3206

Репутация: 609 ±

Замечаний: 0% ±

2003

потому что перед датой в формуле нужно было код валюты написать.
Я добавил =Курс_НБУ("USD";D9) и всё прошло.
На сегодня всё. Убегаю.

С уважением,
Алексей
MS Excel 2003 - the best!!!

Дата: Четверг, 03.05.2012, 17:37 | Сообщение № 10

Группа: Проверенные

Ранг: Форумчанин

Сообщений: 192

Репутация: 6 ±

Замечаний: 0% ±

Спасибо все работает. чуток тормозит календарь, но я думаю что ето иза обновления курса валют. Спасибо!