Sub Rio_loads_metals_from_CBR()

'Author:    Roman Rioran Voronov
'Date:      the 10-th of October, 2014
'Feedback:  voronov_rv@mail.ru

Dim shtA As Worksheet 'Load sheet
Set shtA = ThisWorkbook.Worksheets("Load")

shtA.Cells.Clear

Do While shtA.QueryTables.Count > 0
     shtA.QueryTables(1).Delete
Loop

With shtA.QueryTables.Add(Connection:="URL;http://www.cbr.ru", Destination:=shtA.Range("A1"))
     .WebSelectionType = xlSpecifiedTables
     .WebTables = "4"
     .Refresh
End With
      
End Sub

Sub Rio_adds_data_to_CBR_Argentum_Table()

Cells(1, 1).Offset(Cells(Rows.Count, 1).End(xlUp).Row, 0).Resize(1, 2).Value = [A1:B1].Value

End Sub

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

=МетЦБР()

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

Sub ВывестиСегодняшниеКурсыВсехВалют()
     On Error Resume Next
     Set xmldoc = CreateObject("Msxml.DOMDocument"): xmldoc.async = False
     url_request = "http://www.cbr.ru/scripts/XML_daily.asp?date_req=" + Format(Now, "dd\/mm\/yyyy")
     If xmldoc.Load(url_request) <> True Then Exit Sub
     Set nodeList = xmldoc.SelectNodes("ValCurs"): Set xmlNode = nodeList.Item(0).CloneNode(True)
     Set node_attr = xmlNode.Attributes(0): strDate = node_attr.Value
     Set nodeList = xmldoc.SelectNodes("*/Valute")
     For i = 0 To nodeList.Length - 1
         Set xmlNode = nodeList.Item(i).CloneNode(True)
         Debug.Print "Курс " & xmlNode.ChildNodes(1).Text & " (установлен " & strDate & "): " & _
                     xmlNode.ChildNodes(4).Text & " рублей за " & xmlNode.ChildNodes(2).Text & _
                   " " & xmlNode.ChildNodes(3).Text
     Next
End Sub

Function GetRate(ByVal CurrencyName As String, ByVal RateDate As Date) As Single
     ' функция возвращает курс валюты CurrencyName на дату RateDate
     ' в случае ошибки (неверная дата или название валюты) возвращается 0
     On Error Resume Next
     CurrencyName = UCase(CurrencyName): If Len(CurrencyName) <> 3 Then Exit Function
     Set xmldoc = CreateObject("Msxml.DOMDocument"): xmldoc.async = False
     url_request = "http://www.cbr.ru/scripts/XML_daily.asp?date_req=" + Format(RateDate, "dd\/mm\/yyyy")

     If xmldoc.Load(url_request) <> True Then Exit Function    ' Запрос к серверу ЦБР

     ' Обработка полученного ответа
     Set nodeList = xmldoc.SelectNodes("ValCurs"): Set xmlNode = nodeList.Item(0).CloneNode(True)
     Set node_attr = xmlNode.Attributes(0): strDate = node_attr.Value
     Set nodeList = xmldoc.SelectNodes("*/Valute")
     For i = 0 To nodeList.Length - 1    ' поиск нужной валюты
         Set xmlNode = nodeList.Item(i).CloneNode(True)
         If xmlNode.ChildNodes(1).Text = CurrencyName Then
             CurrencyRate = CDbl(xmlNode.ChildNodes(4).Text)
             divisor = Val(xmlNode.ChildNodes(2).Text)
             GetRate = CurrencyRate / divisor
             Exit Function
         End If
     Next
End Function

Sub ПримерИспользованияФункции_GetRate()
     MsgBox "Сегодня курс доллара к рублю составил " & GetRate("USD", Now), vbInformation
     MsgBox "А вчера курс евро к рублю был равен " & GetRate("EUR", Now - 1), vbInformation
End Sub

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

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

    For Each x In XML.SelectNodes("//CodMet")
          If Val(x.Text) = Met Then
              DragMetDynamic = Val(x.ParentNode.ChildNodes(2).Text)
          End If
      Next

    DragMetDynamic = Val(XML.SelectSingleNode("//DrgMet[CodMet='" & Met & "']/price").Text)

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

Sub GetZoloto()
Dim xmldoc, nodeList
On Error Resume Next
Set xmldoc = CreateObject("Msxml.DOMDocument"): xmldoc.async = False
    'страница выгрузки данных http://www.cbr.ru/scripts/xml_metall.asp?date_req1=12/02/2016&date_req2=12/02/2016
url_request = ("http://www.cbr.ru/scripts/xml_metall.asp?date_req1=" & _
    Format(InputBox("Введите начальную дату поиска в формате ДД.ММ.ГГГГ", "Курс Золота", Date), "dd\/mm\/yyyy") & _
     "&date_req2=" & _
    Format(InputBox("Введите конечную дату поиска в формате ДД.ММ.ГГГГ", "Курс Золота", Date), "dd\/mm\/yyyy"))
   If Not xmldoc.Load(url_request) Then Exit Sub
   Set nodeList = xmldoc.SelectNodes("*/Record[@Code='"1"'][last()]/Buy")
If nodeList.Length Then ActiveCell.Value = CDbl(nodeList.Item(0).ChildNodes(4).Text)
End Sub