strsql = "Select * from clients"
get_conn
get_rs (strsql)
k =  0 
If Not get_rs.EOF Then
    get_rs.MoveFirst
    Do Until get_rs.EOF
        a = get_rs.Fields("id").Value
        b = get_rs.Fields("name").Value
        Combo1.AddItem b, k
        Combo1.ItemData(Combo1.NewIndex) = a
        get_rs.MoveNext
        k = k +  1 
    Loop
End If
conn_rs_comma_close ( 2 )
conn_rs_comma_close ( 1 )

strsql = "Select * from clients"
Set cn = get_conn
Set rs = get_rs(cn, strsql)
k =  0 
If Not rs.EOF Then
    rs.MoveFirst
    Do Until rs.EOF
        a = rs.Fields("id").Value
        b = rs.Fields("name").Value
        Combo1.AddItem b, k
        Combo1.ItemData(Combo1.NewIndex) = a
        rs.MoveNext
        k = k +  1 
    Loop
End If
CloseRs rs
CloseCn cn

Public Function get_conn() As ADODB.Connection
strconn = "Driver={MySQL ODBC 3.51 Driver};Server=localhost;Database=it; User=root;Password=506;Option=3;"
Set Conn = New ADODB.Connection
Conn.Open strconn
End Function
...
Public Function get_rs(strquery As String) As ADODB.Recordset
Set rs = New ADODB.Recordset
rs.Open strquery, Conn, adCmdText
End Function

Public Function get_comm(get_conn As ADODB.Connection, proc As String) As ADODB.Command
Set comm = New ADODB.Command
comm.ActiveConnection = get_conn
comm.CommandType = adCmdStoredProc
comm.CommandText = proc
Set get_comm = comm
Set comm = Nothing
End Function
......
Public Function get_rs(get_conn, strquery) As ADODB.Recordset
Set rs = New ADODB.Recordset
rs.Open strquery, get_conn, adOpenDynamic
Set get_rs = rs
Set rs = Nothing
End Function

Option Explicit
Private cn As New ADODB.Connection
Private cmd As New ADODB.Command

Private bIsOpen As Boolean

'Private mProgramSettings As CProgramSettings


'***********************************************************************
'* Открывает коннест к базе
'***********************************************************************
Function OpenConnect(sConnectionString As String) As Boolean
Dim sErrDesc As String
OpenConnect = False
bIsOpen = False
On Error GoTo labErr

'cn.Provider = "LCPI.IBProvider"
cn.Open sConnectionString
'cn.State
cmd.ActiveConnection = cn
OpenConnect = True
bIsOpen = True
'cn.BeginTrans
Exit Function
labErr:
'OpenConnect = False
sErrDesc = Err.Description
sErrDesc = Replace(sErrDesc, vbLf, " | ", , , vbTextCompare)
'Call OutputErrorMessage(sErrDesc, , , "OpenConnect")
End Function

'***********************************************************************
'* Закрывает коннест к базе
'***********************************************************************
Private Sub CloseConnect()
On Error GoTo labErr
'cn.CommitTrans

labErr:
cn.Close
Set cn = Nothing
Set cmd = Nothing

End Sub

'Private Sub CreateProgramSettings()
'  Set mProgramSettings = New CProgramSettings
'
'  ' Set property settings to determine where the settings will
'  ' be saved. In this example, the settings to into the same location
'  ' used by the VB SaveSetting/GetSettings routines. This could be your
'  ' company name, or the name of another known company such as "Microsoft"
'
'  With mProgramSettings
'    .RootKey = psrHKEY_LOCAL_MACHINE
'    .MainBranch = "SOFTWARE"
'    .RegBase = "ECUS"
'    .Program = "DBOptions"
'    .Section = ""
'
'  End With
'
'End Sub

'***********************************************************************
'* Выполняет запрос подготовленный заранее
'***********************************************************************
Public Function ExecQueryBase(sSql As String) As Boolean
Dim sErrDesc As String
Dim erCur As ADODB.Error
On Error GoTo labErr

ExecQueryBase = False
If Not bIsOpen Then
'    If Not OpenConnect Then
        Exit Function
'    End If
End If
'If cn.State = adStateClosed Then Exit Function

cn.BeginTrans
cmd.CommandText = sSql
cmd.Prepared = True
cmd.Execute
cn.CommitTrans
ExecQueryBase = True
Exit Function

labErr:
On Error Resume Next
If cn.State <> adStateClosed Then
    cn.RollbackTrans
End If

sErrDesc = "" 'Err.Description & " <-> "


' Get the ADO errors.
If cn.Errors.count >  0  Then
    For Each erCur In cn.Errors
        sErrDesc = sErrDesc & erCur.Source  ": " & erCur.Description & " | "
    Next erCur
End If

sErrDesc = Replace(sErrDesc, vbLf, " | ", , , vbTextCompare)
Call OutputErrorMessage(sErrDesc, , , "ExecQueryBase", cmd.CommandText)
End Function

'***********************************************************************
'* Выполняет запрос подготовленный заранее
'***********************************************************************
Public Function ExecQueryBaseRS(sSql As String) As ADODB.Recordset
Dim sErrDesc As String
Dim erCur As ADODB.Error

Set ExecQueryBaseRS = Nothing
'If Not bIsOpen Then
'    If Not OpenConnect Then
'        Exit Function
'    End If
'End If

'cn.BeginTrans
On Error GoTo labErr
cmd.CommandText = sSql
cmd.Prepared = True
Set ExecQueryBaseRS = cmd.Execute.NextRecordset
'cn.CommitTrans
Exit Function
labErr:

If cn.State <> adStateClosed Then
    cn.RollbackTrans
End If

sErrDesc = "" 'Err.Description & " <-> "

On Error Resume Next

' Get the ADO errors.
If cn.Errors.count >  0  Then
    For Each erCur In cn.Errors
        sErrDesc = sErrDesc & erCur.Source & ": " & erCur.Description & " | "
    Next erCur
End If
sErrDesc = Replace(sErrDesc, vbLf, " | ", , , vbTextCompare)
Call OutputErrorMessage(sErrDesc, , , "GetID", cmd.CommandText)
End Function


'***********************************************************************
'* Получает из базы значения генераторов
'* для вставки данных в базу
'***********************************************************************
'Public Function GetId(val As TypeID) As Long
'Dim sErrDesc As String
'Dim erCur As ADODB.Error
'
''If Not bIsOpen Then
''    If Not OpenConnect Then
''        Exit Function
''    End If
''End If
'
'On Error GoTo labErr
'cn.BeginTrans
'Select Case val
'Case ID_PHONE
'    cmd.CommandText = "execute procedure SP_GEN_INF_PHONE_ID"
'Case ID_SUBSCRIBER
'    cmd.CommandText = "execute procedure SP_GEN_INF_SUBSCRIBER_ID"
'Case ID_DIVISION
'    cmd.CommandText = "execute procedure SP_GEN_INF_DIVISION_ID"
'End Select
' 'automating defining of parameters ----------------------------------------------
''cmd.Parameters.Refresh
'cmd.Parameters.Append cmd.CreateParameter("ID", adInteger, adParamOutput)
'cmd.Execute
'GetId = cmd.Parameters("ID").Value
'cmd.Parameters.Delete (0)
'cn.CommitTrans
'Exit Function
'labErr:
'cmd.Parameters.Delete (0)
'If cn.State <> adStateClosed Then
'    cn.RollbackTrans
'End If
'
'sErrDesc = "" 'Err.Description & " <-> "
'
'On Error Resume Next
'
'' Get the ADO errors.
'If cn.Errors.Count > 0 Then
'    For Each erCur In cn.Errors
'        sErrDesc = sErrDesc & erCur.Source & ": " & erCur.Description & " | "
'    Next erCur
'End If
'sErrDesc = Replace(sErrDesc, vbLf, " | ", , , vbTextCompare)
'Call OutputErrorMessage(sErrDesc, , , "GetID", cmd.CommandText)
'Err.Raise 70, "GetID"
'End Function

Public Sub ClearDataInBD()
' Очищаем БД от данных
'If Not bIsOpen Then
'    If Not OpenConnect Then
'        If g_iRowError > 2 Then
'            If Not shErr Is Nothing Then
'                 shErr.Visible = xlSheetVisible
'                 shErr.Select
'                 Set shErr = Nothing
'                 g_iRowError = 2
'            End If
'        End If
'        Exit Sub
'    End If
'End If
Call ExecQueryBase("delete from INF_SUBSCRIBER")
Call ExecQueryBase("delete from INF_DIVISION")
Call ExecQueryBase("delete from INF_PHONE")
Call ExecQueryBase("delete from INF_LINK_PDS")
Call ExecQueryBase("delete from CATEG")
End Sub


Private Sub Class_Initialize()
'If Not OpenConnect Then
'    Err.Raise vbObjectError + 1, "clsDataBaseWork : Class_Initialize", _
'        , ThisWorkbook.Path & "\Создание_справочника.chm"
'End If
End Sub

Private Sub Class_Terminate()
Call CloseConnect
End Sub

Option Explicit
Dim g_BD As clsDataBaseWork
Dim v As Variant
Dim mCol As Collection
Dim sh As Worksheet, shOut As Worksheet

Sub LoopInData()
If g_BD Is Nothing Then
    Set g_BD = New clsDataBaseWork
End If
Set mCol = New Collection
'Set sh = Application.Worksheets("Лист3")
Set sh = Application.Worksheets("Лист1")
' Если база не открылась, работать дальше нельзя
If Not g_BD.OpenConnect("Provider=sqloledb;Data Source=igor;Initial Catalog=ttt;Integrated Security=SSPI;") Then
    Set g_BD = Nothing
    Exit Sub
End If
Dim nRow As Long, nCol As Long, i As Long
nRow =  1 
nCol =  1 
For nRow =  2  To  666 
    sh.Cells(nRow,  15 ).Value = InsertRec(nRow)
Next nRow
Set g_BD = Nothing
Set mCol = Nothing
Set sh = Nothing
Set shOut = Nothing
End Sub

Function InsertRec(nRow As Long) As String
Dim s As String, sCode As String, rs As Recordset
s = "INSERT INTO [ttt].[dbo].[objects](code_owher, name, land_tipe, number, code_land, adres) VALUES(" & _
    CStr(sh.Cells(nRow,  1 ).Value) & ", '" & Trim(CStr(sh.Cells(nRow,  3 ).Value)) & "', " & _
    CStr(sh.Cells(nRow,  4 ).Value) & ", " & CStr(sh.Cells(nRow,  5 ).Value) & ", " & _
    CStr(sh.Cells(nRow,  6 ).Value) & ", " & CStr(sh.Cells(nRow,  7 ).Value) & ", " & _
    vbCrLf & "SELECT SCOPE_IDENTITY() AS code"
Set rs = g_BD.ExecQueryBaseRS(s)
'rs.MoveFirst
sCode = CStr(rs.Fields("code").Value)
Set rs = Nothing
InsertRec = sCode
s = "INSERT INTO [ttt].[dbo].[objects_plus_directions](code_directions, code_objects) VALUES(" & _
    CStr(sh.Cells(nRow,  14 ).Value) & ", " & sCode & ")"
 Call g_BD.ExecQueryBase(s)

'Call g_BD.ExecQueryBase(s)
'rs.MoveFirst
Debug.Print s
End Function