Sub ЗагрузитьБалансВнешняяАналитика()
    Лист1.Select
    Call Загрузка_таблицы_на_сервер(False, True)
End Sub


Sub Загрузка_таблицы_на_сервер(Optional trunc As Boolean = False, Optional IsMSSQL As Boolean = True)

With Application: .ScreenUpdating = True: .DisplayAlerts = False: .Calculation = xlCalculationManual: End With

Dim time As Date: time = Now()

Dim a As Long, b As Long, sh_num As Long
Dim fact_list_row As Byte: fact_list_row = 2 'строка с заголовком
Dim format_row As Byte: format_row = 3 'строка с фактом

Dim sql As String, sql_val As String, sql_table As String, fld As String
Dim f_text As String, f_number As Double, f_number_s As String, f_date As Date 'значения
Dim fld_all As String
Dim ASY As Variant, send As Boolean

Dim tbl As String: tbl = ActiveSheet.Name


'создаем соединения
Dim ASY1 As New async, ASY2 As New async, ASY3 As New async, ASY4 As New async, ASY5 As New async, ASY6 As New async, ASY7 As New async, ASY8 As New async
            a = 0
            For Each ASY In Array(ASY1, ASY2, ASY3, ASY4, ASY5, ASY6, ASY7, ASY8)
                a = a + 1
                ASY.Connect
                ASY.ID = a
                While ASY.Connection.State = 2: Wend 'ждем готовности всех соединений
            Next ASY

      tbl = ActiveSheet.Name
        'чистим таблицу на сервере ORACLE
   ' If trunc Then
    '    sql = "truncate table " & tbl & ""
     '   ASY1.Query (sql)
      '  ASY1.ConnectComplete
    'End If
        
        Dim cnt_str As Integer
        cnt_str = ActiveSheet.Cells(2, 1).End(xlToRight).Column
        
        'собираем поля
        fld_all = vbNullString
        For a = 1 To cnt_str
        fld_all = fld_all & ActiveSheet.Cells(2, a) & ","
        Next a
        fld_all = Left(fld_all, Len(fld_all) - 1)
        
        
        Dim c As Long
            For a = 3 To ActiveSheet.Cells(2, 1).End(xlDown).Row
            'If a = 401 Then MsgBox 1
            DoEvents
                sql_val = ""
                                sql_val = ""
                                For b = 1 To 1 + cnt_str
                                        fld = "": fld = ActiveSheet.Cells(2, b).Value
                                        If IsMSSQL Then
                                                Select Case ActiveSheet.Cells(1, b).Value
                                                    Case "t": f_text = ActiveSheet.Cells(a, b).Value:                                   sql_val = sql_val & "'" & f_text & "' " & fld & ","
                                                    Case "n":  f_number_s = Replace(CStr(ActiveSheet.Cells(a, b).Value), "'", ""):  sql_val = sql_val & "cast(replace('" & f_number_s & "',',','.') as float) " & fld & ","
                                                    Case "d": f_date = ActiveSheet.Cells(a, b).Value:                                    sql_val = sql_val & "{ d '" & Format(f_date, "yyyy-mm-dd") & "'} " & fld & ","
                                                End Select
                                            Else 'ORACLE
                                                Select Case ActiveSheet.Cells(1, b).Value
                                                    Case "t": f_text = Replace(ActiveSheet.Cells(a, b).Value, "'", ""):                                 sql_val = sql_val & "'" & f_text & "' " & fld & ","
                                                    Case "n": f_number = ActiveSheet.Cells(a, b).Value: f_number_s = CStr(f_number):    sql_val = sql_val & "cast(replace('" & f_number_s & "',',','.') as float) " & fld & ","
                                                    Case "d": f_date = ActiveSheet.Cells(a, b).Value:                                    sql_val = sql_val & "to_date('" & Format(f_date, "dd.mm.yyyy hh:mm:ss") & "','DD.MM.YYYY HH24:MI:SS') " & fld & ","
                                                End Select
                                        End If
                                Next b
                                    'добавляем юнион
                                    If IsMSSQL Then
                                        sql_val = Left(sql_val, Len(sql_val) - 1) & " " & vbNewLine & " Union all " & vbNewLine
                                        Else 'ORACLE
                                        sql_val = Left(sql_val, Len(sql_val) - 1) & " from dual" & vbNewLine & " Union all " & vbNewLine
                                    End If
                                    
                                    sql_table = sql_table & "Select " & sql_val
                                                                         
                                            'и как мы набрали достаточное кол-во строчек, отправляем данные на сервер
                                                            If a Mod 200 = 0 Then
                                                                If Not sql_table = "" Then
                                                                    sql_table = Left(sql_table, Len(sql_table) - 12)
                                                                    sql = "insert into " & tbl & " (" & fld_all & ") select * from (" & sql_table & ") a"
restart_send:
                                                                        send = False
                                                                                    For Each ASY In Array(ASY1, ASY2, ASY3, ASY4, ASY5, ASY6, ASY7, ASY8)
                                                                                        If ASY.Connection.State = 1 Then
                                                                                            Debug.Print "Запрос отправлен в канал: " & ASY.ID
                                                                                            Application.StatusBar = "Лист: " & 1 & " из " & 1 & ".Строка: " & a & " из " & ActiveSheet.UsedRange.Rows.Count
                                                                                            'Debug.Print sql
                                                                                            ASY.Query sql: send = True: Exit For
                                                                                             
                                                                                                Else
                                                                                                Debug.Print "Канал " & ASY.ID & " занят."
                                                                                        End If
                                                                                    Next ASY
                                                                                If send = False Then
                                                                                    Debug.Print "Все соединения заняты, ожидаю: " & TimeSerial(Hour(Now()), Minute(Now()), Second(Now()) + 5)
                                                                                    Application.Wait TimeSerial(Hour(Now()), Minute(Now()), Second(Now()) + 2)
                                                                                    GoTo restart_send
                                                                                End If
                                                                    sql_table = ""
                                                                End If
                                                            End If
               
            Next a
        
        If Not sql_table = "" Then
            sql_table = Left(sql_table, Len(sql_table) - 12)
            sql = "insert into " & tbl & " (" & fld_all & ") select * from (" & sql_table & ") a"
            'MsgBox sql
            ASY1.Query (sql)
            sql_table = ""
            ASY1.ConnectComplete
        End If






With Application: .StatusBar = False: .DisplayAlerts = True: .Calculation = xlCalculationAutomatic: .ScreenUpdating = True: End With
Debug.Print "Загрузка завершена"
End Sub

Option Explicit
Public Connection As Object
Public Recordset As Object
Public ID As Long


Private Const MSSQLConnectionString As String = "Provider=SQLOLEDB.1;Integrated Security=SSPI;Persist Security Info=True;User ID=** USER_ID **;Password= ** PASS ** ;Initial Catalog = ** MAIN **;Data Source= ** MY_SERVER **"
'Private Const OracleConnectionString As String = "DSN=OracleODBC;UID=PAU;PWD=DVN7Fxn0;"

Public Sub Create()
Set Me.Connection = CreateObject("ADODB.Connection")
End Sub
Public Sub Destroy()
Set Me.Connection = Nothing
End Sub
Public Sub Connect()
Me.Connection.commandtimeout = 0
Me.Connection.connectiontimeout = 0
Me.Connection.Open MSSQLConnectionString, Options:=16 '!!!!!! Çäåñü íàäî èçìåíèòü ñòðîêó ïîäêëþ÷åíèÿ íà íóæíóþ, ëèáî ïåðåäàòü ïàðàìåòð âûáîðà ñòðîêè â êëàññ
End Sub
Public Sub Disconnect()
Me.Connection.Close
End Sub
Private Sub Class_Initialize()
Call Me.Create
End Sub
Private Sub Class_Terminate()
Dim d As Date: d = Now()

restart_terminate:
If Me.Connection.State <> 1 Then
GoTo restart_terminate
Else
Call Me.Disconnect
End If
Call Me.Destroy
Debug.Print "Íà çàêðûòèå êàíàëà " & Me.ID & " ïîòðà÷åíî: " & Format(Now() - d, "HH:MM:SS")
End Sub

Public Function Query(ByVal QueryString As String) As Date
If Me.Connection Is Nothing Then
Call Me.Create
End If
If Me.Connection.State = 0 Then
Call Me.Connect
End If

While Me.Connection.State <> 1: Wend
Me.Connection.Execute QueryString, 0, 16
End Function

Public Function Query_RS(ByVal QueryString As String) As Date
If Me.Connection Is Nothing Then
Call Me.Create
End If
If Me.Connection.State = 0 Then
Call Me.Connect
End If

Set Me.Recordset = CreateObject("ADODB.recordset")

wait_connection:
If Me.Connection.State <> 1 Then GoTo wait_connection

Me.Recordset.Open QueryString, Me.Connection
End Function


Public Sub ConnectComplete(Optional bool As Boolean = False)
While Me.Connection.State <> 1: Wend
End Sub

Sub buttom()

AI = ActiveSheet.Range("F1")
With ActiveSheet.ListObjects(1)
        .QueryTable.CommandText = "select dfp.valid_from_dt, dfp.contr_term, dfp.FTP_DISB  from dict_ftp_price dfp where dfp.VALID_TILL_DT = Date '4000-01-01' and dfp.contr_term = " & AI
        
  
        .Refresh
    End With

    
End Sub

Select * from
sales
where
sales.dt = date'2015-01-01'

Select * from
sales
where
sales.dt = date'&D'