Курс доллара для любой заданной даты

Sub GetCurrencyRateNBU_after_2012_01_04()

 ' программа обновления курсов с сайта НБУ
 ' обновляет только USD и UAH, тем кто хочет добавить иные валюты - просто скопируйте сегмент и 
 'переименуйте валюту
 ' переписана 04,01,2012 в связи с обновлением дизайна сайта НБУ
 ' собрана из запчастей взятых на просторах интернета.

 Dim sURI As String
 Dim oHttp As Object
 Dim HTMLcode As String

 Dim C As Range
 Dim Q As Long
 Dim iP As Long, z As Long
 Dim S As String, S1 As String, iOnlyTable As String
 Dim b As Object
 Dim massive(30, 5)
 Dim iDatas As Date

 iiDate = Cells(21, 2).Value
 sURI = "[URL=http://bank.gov.ua/control/uk/curmetal/currency/search?formType=searchFormDate&time_step=daily&date]http://bank.gov.ua/control/uk/curmetal/currency/search?formType=searchFormDate&time_step=daily&date[/URL]=" & iiDate
 On Error Resume Next
 Set oHttp = CreateObject("MSXML2.XMLHTTP")
 If Err.Number <> 0 Then
 Set oHttp = CreateObject("MSXML.XMLHTTPRequest")
 End If
 If oHttp Is Nothing Then Exit Sub 'вот здесь если вылетает, значит можно попытаться подключить библиотеки в Tools-References
 On Error GoTo ConnectionError
 oHttp.Open "GET", sURI, False
 On Error GoTo ConnectionError
 oHttp.send
 HTMLcode = oHttp.responseText
 iP = InStr(1, HTMLcode, "України<br/>встановлює")
 HTMLcode = Mid(HTMLcode, iP, 10000) 'обрезали оставив только диапазон который отвечает за название страницы и дату содержимого
 iP = InStr(1, HTMLcode, "<td class=") + 6 + 11
 iDatas = Mid(HTMLcode, iP, 10)
 iOnlyTable = Mid(HTMLcode, InStr(100, HTMLcode, "<table cellpadding="), InStr(1000, HTMLcode, "</table>") - InStr(100, HTMLcode, "<table cellpadding=") + 10)
 If MsgBox("Использовать данные НБУ за " & iDatas & " ?", vbYesNo Or vbQuestion Or vbDefaultButton1, Application.Name) = vbNo Then Exit Sub
 Set Doc = CreateObject("HTMLFile")
 Doc.Write iOnlyTable ' я лентяй и не собираюсь парсить текст: делаем из куска кода таблицу на тегах
 Set b = Doc.all.tags("TABLE") ' даём понять, что нам нужна таблица (хотя кроме неё там ничего нет)
 indikatorProhoda = 0
 For Each uTableElement In b
 iRows = uTableElement.Rows.Length 'здесь получаю кол-во строк
 iCells = uTableElement.Cells.Length 'здесь получаю кол-во ячеек
 If (iCells / iRows) <> 5 Or ((iCells Mod iRows) <> 0) Then 'здесь проверяю таблицу на размерность - 5 колонок и нет объединений
 MsgBox "Table size is changed"
 GoTo vilet
 End If

 For j = 5 To uTableElement.Cells.Length - 1 ' побежали по ячейкам
 indCol = (((j - 1) Mod 5) + 1)
 indRow = (j \ 5)
 'Cells(indRow + 1, indCol) = uTableElement.Cells(j).innerHTML ' для наглядности в ячейки
 massive(indRow, indCol) = uTableElement.Cells(j).innerHTML ' в переменную
 indikatorProhoda = 1 ' убеждаемся в том, что массив наполнялся
 Next j

 vilet:
 Next uTableElement
 If indikatorProhoda = 0 Then
 MsgBox "перезапустите программу с правильной датой"
 Else
 For i = 1 To 29
 If massive(i, 1) = "USD" Then
 Cells(8, 4).Value = massive(i, 4) / massive(i, 2)
 indikatorProhoda = indikatorProhoda + 1
 End If
 If massive(i, 1) = "EUR" Then
 Cells(9, 4).Value = massive(i, 4) / massive(i, 2)
 indikatorProhoda = indikatorProhoda + 1
 End If
 Next i
 If indikatorProhoda = 3 Then
 Cells(7, 4).Values = Format(CDate(iDatas), "DD.MM.YYYY")
 MsgBox "Курсы обновлены" ', окно сейчас закроется
 Else
 MsgBox "Обновление прошло, только не успешно. Не все данные были найдены. Лезь в код."
 End If
 'Unload Me
 'FormForCurs.Hide
 Calculate
 End If

 NextForLoop:
 Set oHttp = Nothing
 Exit Sub
 ConnectionError:
 Call MsgBox("Ошибка связи с сервером НБУ", vbExclamation, Application.Name)
 End Sub