Option Explicit
Sub SetClipboardText()

Dim i As Long
Dim contant As String
Dim MS1 As Byte

'Проверка на выбор целого столбца!
If Selection.Rows.Count = ActiveSheet.Rows.Count Then
    MS1 = MsgBox("Вы выбрали целый столбец данных!," & Chr(10) & "Продолжить?", vbOKCancel)
    If MS1 = vbOK Then GoTo StartIT Else End
End If
'Проверка на выбор только одной ячейки! на выбор только одного столбца!
If Selection.Count = 0 Or Selection.Count = 1 Or Selection.Columns.Count > 1 Then
    MsgBox "Нужно выбрать более одной ячейки в одном столбце!", vbCritical
    End
End If

StartIT:
For i = Selection.Row To Selection.Row + Selection.Rows.Count - 1
    If contant = "" Then
        contant = Cells(i, Selection.Column)
    Else
        contant = contant & "," & Cells(i, Selection.Column)
    End If
Next i
With GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
        .SetText contant
        .PutInClipboard
End With
End Sub

Sub Change_line()
For ii = 1 To ThisWorkbook.ActiveSheet.ChartObjects.Count
    Set co = ThisWorkbook.ActiveSheet.ChartObjects(ii).Chart
    Debug.Print co.Name
    If co.SeriesCollection.Count > 1 Then
        For i = 1 To co.SeriesCollection.Count
            If co.SeriesCollection(i).Name Like "*Караван*" Then
                Debug.Print co.SeriesCollection(i).Name
                With co.SeriesCollection(i).Format.Line
                    .Weight = 3
                    .DashStyle = msoLineSysDash
                End With
                co.SeriesCollection(i).Smooth = True
            Else
                With co.SeriesCollection(i).Format.Line
                    .Weight = 2.5
                    .DashStyle = msoLineSolid
                End With
                co.SeriesCollection(i).Smooth = False
            End If
        Next i
    End If
Next ii
End Sub

Sub Change_line()
For Each co In ThisWorkbook.ActiveSheet.ChartObjects
    Debug.Print co.Name
    If co.Chart.SeriesCollection.Count > 1 Then
        For i = 1 To co.Chart.SeriesCollection.Count
            If co.Chart.SeriesCollection(i).Name Like "*Караван*" Then
                Debug.Print co.Chart.SeriesCollection(i).Name
                co.Chart.SeriesCollection(i).Select
                With Selection.Format.Line
                    .Weight = 3
                    .DashStyle = msoLineSysDash
                End With
                co.Chart.SeriesCollection(i).Smooth = True
            Else
                co.Chart.SeriesCollection(i).Select
                With Selection.Format.Line
                    .Weight = 2.5
                    .DashStyle = msoLineSolid
                End With
                co.Chart.SeriesCollection(i).Smooth = False
            End If
        Next i
    End If
Next co
End Sub

Sub dd()

With ActiveWorkbook.Connections("K2_DECODING_DAILY").OLEDBConnection
        .BackgroundQuery = True
        .CommandText = Array("Select * from ANALYTICS.DECODING_DAILY")
        .CommandType = xlCmdSql
        .Connection = _
        "OLEDB;Provider=MSDAORA.1;Password=Password;User ID=User;Data Source=Source"
        .RefreshOnFileOpen = False
        .SavePassword = True
        .SourceConnectionFile = ""
        .SourceDataFile = ""
        .ServerCredentialsMethod = xlCredentialsMethodIntegrated
        .AlwaysUseConnectionFile = False
        .ServerFillColor = False
        .ServerFontStyle = False
        .ServerNumberFormat = False
        .ServerTextColor = False
    End With
    With ActiveWorkbook.Connections("K2_DECODING_DAILY")
        .Name = "K2_DECODING_DAILY"
        .Description = "Исключительно для сетевого Daily"
    End With
    With ActiveSheet.ListObjects.Add(SourceType:=0, Source:= _
        "OLEDB;Provider=MSDAORA.1;Password=Password;User ID=User;Data Source=Source", _
        Destination:=Range("$A$1")).QueryTable
        .CommandType = xlCmdSql
        .CommandText = Array("Select * from ANALYTICS.DECODING_DAILY")
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .BackgroundQuery = True
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = True
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .PreserveColumnInfo = True
        .ListObject.DisplayName = "Для_DECODING_DAILY"
        .Refresh BackgroundQuery:=False
    End With
End Sub 

Sub Insert_In_Table()

Dim cn As Object
Dim cmd As Object
Dim strSQL As String
Dim sh1 As Worksheet
Dim iRow As Long
Dim ADOErr, r

Debug.Print Now

Set cn = CreateObject("ADODB.Connection")
cn.Provider = "MSDAORA"
cn.ConnectionString = "User ID=analytics;Password=yseason;Data Source=ADVENTIS"

On Error GoTo CnErrorHandler
cn.Open
'Явно начинаем транзакцию во избежание режима AutoCommit=ON
cn.BeginTrans

'Создаем команду
Set cmd = CreateObject("ADODB.Command")
cmd.ActiveConnection = cn
cmd.CommandText = _
"insert into analytics.EXCHANGE_RATE(DATE_REP, NBU, BLACK_MARKET, Interbank) values (?,?,?,?)"

'Для упрощения примера считаем, что данные находятся в столбцах A1 и J1 первого в книге листа
'Создаем соответствующий Range-объект
Set sh1 = ThisWorkbook.Sheets("На заливку")
Set r = sh1.Range(sh1.[A1], sh1.[D1].End(xlDown))
cmd.Parameters.Append cmd.CreateParameter("DATE_REP", 200, 1, 10)
cmd.Parameters.Append cmd.CreateParameter("NBU", 200, 1, 100)
cmd.Parameters.Append cmd.CreateParameter("BLACK_MARKET", 200, 1, 100, Null)
cmd.Parameters.Append cmd.CreateParameter("INTERBANK", 200, 1, 100)
'Проходим по всем заполненным строкам

For iRow = 2 To r.Rows.Count
    cmd.Parameters("DATE_REP").Value = r.Cells(iRow, 1).Value
    cmd.Parameters("NBU").Value = r.Cells(iRow, 2).Value
    cmd.Parameters("BLACK_MARKET").Value = r.Cells(iRow, 3).Value
    cmd.Parameters("INTERBANK").Value = r.Cells(iRow, 4).Value
    cmd.Execute
Next iRow

'Сохраняем данные
cn.CommitTrans

'Удаляем команду и закрываем соединение
cn.Close
Set cn = Nothing
Debug.Print Now
Exit Sub

CnErrorHandler:
For Each ADOErr In cn.Errors        'Отладчик ошибок подключения
    MsgBox "№ ошибки " & ADOErr.Number & Chr(10) & _
    "Описание: " & ADOErr.Description & Chr(10) & _
    "Источник: " & ADOErr.Source, vbCritical
    Debug.Print "№ ошибки " & ADOErr.Number & Chr(10) & _
    "Описание: " & ADOErr.Description & Chr(10) & _
    "Источник: " & ADOErr.Source
Next
cn.Close
Set cn = Nothing
End Sub

Function NBU_RATE(sCurr$, iiDate As Date)
     'moonexcel.com.ua
     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
     sURI = "http://bank.gov.ua/control/uk/curmetal/currency/search?formType=searchFormDate&time_step=daily&date=" & iiDate & "&execute"
      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 Function
      On Error GoTo ConnectionError
     oHttp.Open "GET", sURI, False
      On Error GoTo ConnectionError
     oHttp.Send
     htmlcode = oHttp.responseText
     iP = InStr(1, htmlcode, "України<")
     htmlcode = Mid(htmlcode, iP, 10000)
     iP = InStr(1, htmlcode, "<") + 6 + 11  '">
     Dim ss As String
     For i = 1 To 10000
          ss = Trim(Mid(htmlcode, i, 10))
          If Mid(ss, 6, 3) = ".20" And IsDate(ss) Then Exit For
     Next i
     iDatas = CDate(ss) 'Mid(htmlcode, iP, 10)
     iOnlyTable = Mid(htmlcode, InStr(100, htmlcode, "<" & "table cellpadding="), InStr(1000, htmlcode, "<" & "/table>") - _
     InStr(100, htmlcode, "<" & "table cellpadding=") + 10) '">
     Set Doc = CreateObject("HTMLFile")
     Doc.Write iOnlyTable
     Set b = Doc.all.tags("TABLE")
       
     For Each uTableElement In b
     iRows = uTableElement.Rows.Length
     iCells = uTableElement.Cells.Length
     j = 0
     For k = 1 To iRows
        For l = 1 To 5
            j = j + 1
            massive(k, l) = uTableElement.Cells(j - 1).innerHTML
            If j = uTableElement.Cells.Length Then GoTo 1
        Next l
    Next k
1:
     Next uTableElement
       
     For k = 2 To iRows
        For l = 1 To 5
            If massive(k, l) = sCurr Then
                NBU_RATE = Replace(massive(k, 5), ".", ",")
                NBU_RATE = NBU_RATE / massive(k, 3)
            End If
         Next l
    Next k
      
    Calculate
NextForLoop:
    Set oHttp = Nothing
    Exit Function
ConnectionError:
    End Function