Developing.ru

Код: Выделить всё

   Dim DBFullName As String
    Dim Cnct As String, Src As String
    Dim Connection As ADODB.Connection
    Dim Recordset As ADODB.Recordset
    Dim Col As Integer

'   Database information
    DBFullName = ThisWorkbook.Path & "\База данных2.mdb"
    
'   Open the connection
    Set Connection = New ADODB.Connection
    Cnct = "Provider=Microsoft.ACE.OLEDB.12.0;"
    Cnct = Cnct & "Data Source=" & DBFullName & ";"
    Connection.Open ConnectionString:=Cnct
    
'   Create RecordSet
    Set Recordset = New ADODB.Recordset
    
    With Recordset
'       Filter
        Src = "SELECT * FROM Контакты"
        Src = Src & " WHERE Фамилия = 'Иванов'"
        Src = Src & " and Имя = 'Иван'"
        Src = Src & " and Отчество = 'Иванович'"
        .Open Source:=Src, ActiveConnection:=Connection
    End With
        
    MsgBox Recordset.RecordCount
    
    If Recordset.RecordCount < 0 Then ' проверка, если уже эта запись
            Src = "INSERT INTO Контакты (Фамилия, Имя, Отчество)"
            Src = Src & " VALUES ('Иванов', 'Иван', 'Иванович')"
            'запись в базу данных
            Connection.Execute Src, adCmdText + adExecuteNoRecords
    Else
        MsgBox "Уже есть в списке!"
    End If
    
    Set Recordset = Nothing
    Connection.Close
    Set Connection = Nothing

Код: Выделить всё

Const sCon$ = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source="
Const sBase$ = "\База данных2.mdb"
Const sQl$ = "SELECT * FROM Контакты WHERE Фамилия = '"
Const sQ2$ = "' and Имя = '", sQ3$ = "' and Отчество = '", sQ4$ = "'"
Const sIl = "INSERT INTO Контакты (Фамилия, Имя, Отчество) VALUES ('"
Const sI2 = "', '", sI3 = "')"
Sub Proc()

Dim DBFullName$, Src$, sV(2) As String
Dim cn As ADODB.Connection, rs As ADODB.Recordset

sV(0) = "Иванов": sV(1) = "Иван": sV(2) = "Иванович"
DBFullName = ThisWorkbook.Path + sBase
Set cn = New ADODB.Connection
cn.Open ConnectionString:=sCon + DBFullName + ";"

Set rs = New ADODB.Recordset
    Src = sQl + sV(0) + sQ2 + sV(1) + sQ3 + sV(2) + sQ4
rs.Open Src, cn

If Not rs.EOF Then   ' проверка, если уже эта запись
    MsgBox "Уже есть в списке!"
Else
    cn.Execute sIl + sV(0) + sI2 + sV(1) + sI2 + sV(2) + sI3
End If

'cn.Close - соединение открыто зачем его закрывать
'изменился только рекордсет(набор записей) его можно обновить не закрывая
rs.Requery
'For Col = 0 To rs.Fields.Count - 1 ' если данные выкладываются на заготовку (шаблон) этот код лишний
    'Range("A1").Offset(0, Col).Value = rs.Fields(Col).Name
'Next
Range("A2:AA65000").Clear 'сохранение имен полей
Range("A2").CopyFromRecordset rs
Set rs = Nothing
cn.Close
Set cn = Nothing
End Sub

Код: Выделить всё

Const sCon$ = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source="
Const sQl$ = "SELECT * FROM Контакты WHERE Фамилия = '"
Const sQ2$ = "' and Имя = '", sQ3$ = "' and Отчество = '", sQ4$ = "'"
Sub Proc()

Dim DBFullName$, Src$, sV(2) As String
Dim cn As ADODB.Connection, rs As ADODB.Recordset

sV(0) = "Иванов": sV(1) = "Иван": sV(2) = "Иванович"
DBFullName = ThisWorkbook.Path + "\База данных2.mdb"
Set cn = New ADODB.Connection
cn.Open ConnectionString:=sCon + DBFullName + ";"
Set rs = New ADODB.Recordset
    Src = sQl + sV(0) + sQ2 + sV(1) + sQ3 + sV(2) + sQ4
rs.Open Src, cn, adOpenDynamic, adLockOptimistic

If rs.EOF Then
    rs.AddNew: rs("Фамилия") = sV(0): rs("Имя") = sV(1): rs("Отчество") = sV(2): rs.Update
End If
rs.Requery
Range("A2:AA65000").Clear
Range("A2").CopyFromRecordset rs
rs.Close
Set rs = Nothing
cn.Close
Set cn = Nothing
End Sub