Как в VBA для Excel создать запрос к базе данных SQLite и получить данные?

Вот мой код:

    Sub GetCadastralInfo()
    Dim dbPath As String
    Dim cadNumber As String
    Dim conn As Object
    Dim rs As Object
    Dim sql As String
    Dim result As Variant
    Dim i As Integer

    On Error GoTo ErrorHandler

    dbPath = "C:\my_python\Bot_aio\akt\egrn_kpt.db"
    
    cadNumber = Trim(ActiveCell.Value) ' Удалить лишние пробелы
    
    ' Соединение
    Set conn = CreateObject("ADODB.Connection")
    Set rs = CreateObject("ADODB.Recordset")
    
    ' Откройте соединение с базой данных
    conn.Open "Driver={SQLite3 ODBC Driver};Database=" & dbPath & ";"
    
    ' SQL запрос для поиска информации по кадастровому номеру
    sql = "SELECT value_by_document FROM ZY WHERE cad_n = '" & cadNumber & "';"
    
    ' Выполните запрос и получите набор записей
    Set rs = conn.Execute(sql)
    
    ' Инициализация переменной строки
    i = 1 ' Начинаем с первой строки
    
    ' Проверка наличия данных
    If Not rs.EOF Then
        While Not rs.EOF
            Cells(i, 1).Value = rs.Fields(0).Value
            ' Если у вас есть второе поле, убедитесь, что оно существует
            If rs.Fields.Count > 1 Then
                Cells(i, 2).Value = rs.Fields(1).Value
            End If
            i = i + 1
            rs.MoveNext
        Wend
    Else
        MsgBox "Нет данных для данного кадастрового номера.", vbInformation
    End If
    
    ' Закрытие набора записей и соединения
    rs.Close
    conn.Close

    Exit Sub

ErrorHandler:
    MsgBox "Ошибка: " & Err.Description, vbCritical, "Ошибка"
    If Not rs Is Nothing Then
        If rs.State = 1 Then rs.Close ' Закрываем, если открыто
    End If
    If Not conn Is Nothing Then
        If conn.State = 1 Then conn.Close ' Закрываем, если открыто
    End If
End Sub

Почему то постоянно выдает - "Нет данных для данного кадастрового номера.", хотя в базе имеется запись в таблице ZY (это земельные участки) и хочу по столбцу value_by_document (это ВРИ земельного участка, для примера - "Для ведения личного подсобного хозяйства"). Так вот, в ячейку A1 (для примера) ввожу кадастровый номер (для примера - "52:15:0140112:10"), далее нажимаю сочетание клавиш ctrl+f8 и выполняю этот код и выводит что нет данных. Драйвер SQLite ODBC Driver устанавливал с сайта. Хотел бы сделать код который бы обращался к базе данных. Помогите пожалуйста.


Ответы (2 шт):

Автор решения: Михаил Ширшов

Благодаря ответу @Akina, получился вот такой код, может быть не очень, но вставляет данные из базы SQLite. можно и дальше двигаться

Sub GetCadastralInfo()
    Dim dbPath As String
    Dim cadNumber As String
    Dim conn As Object
    Dim rs As Object
    Dim sql As String

    On Error GoTo ErrorHandler

    dbPath = "C:\my_python\Bot_aio\akt\egrn_v.db"
    
    cadNumber = Trim(ActiveCell.Value)

    Set conn = CreateObject("ADODB.Connection")
    Set rs = CreateObject("ADODB.Recordset")

    conn.Open "Driver={SQLite3 ODBC Driver};Database=" & dbPath & ";"
    
    sql = "SELECT by_document FROM Information_objects WHERE cad_numb = '" & cadNumber & "';"
    Set rs = conn.Execute(sql)
    

    If Not rs.EOF Then
        rs.MoveFirst ' Установить указатель на первую запись
        
        ' Цикл для перебора записей
        Do While Not rs.EOF
            Range("B1").Value = rs.Fields(0).Value
            rs.MoveNext ' Перейти к следующей записей
        Loop
    Else
        MsgBox "Нет данных для данного кадастрового номера.", vbInformation
    End If
    
    rs.Close
    conn.Close

    Exit Sub

ErrorHandler:
    Debug.Print Err.Description

    If Not rs Is Nothing Then
        If rs.State = 1 Then rs.Close ' Закрыть, если открыто
    End If
    If Not conn Is Nothing Then
        If conn.State = 1 Then conn.Close ' Закрыть, если открыто
    End If
End Sub
→ Ссылка
Автор решения: Михаил Ширшов
Function ПоискВБазе(КадастровыйНомер As String, НаименованиеШапкиТаблицы As String) As Variant
    Dim dbPath As String
    Dim conn As Object
    Dim rs As Object
    Dim sql As String
    Dim resultValue As Variant
    Dim dateList As Collection
    Dim dateStr As String
    Dim currentDate As Date
    Dim maxDate As Date
    Dim maxDateStr As String
    Dim i As Integer

    On Error GoTo ErrorHandler
    dbPath = "C:\my_python\Bot_aio\akt\egrn_v.db"
    КадастровыйНомер = Trim(КадастровыйНомер)
    Set conn = CreateObject("ADODB.Connection")
    Set rs = CreateObject("ADODB.Recordset")
    conn.Open "Driver={SQLite3 ODBC Driver};Database=" & dbPath & ";"
    
    ' Получение всех дат
    sql = "SELECT date_formation FROM Information_objects WHERE cad_numb = '" & КадастровыйНомер & "';"
    Set rs = conn.Execute(sql)
    
    Set dateList = New Collection
    If Not rs.EOF Then
        Do While Not rs.EOF
            dateStr = rs.Fields("date_formation").Value
            On Error Resume Next
            currentDate = CDate(dateStr)
            If Err.Number = 0 Then
                dateList.Add currentDate
            End If
            On Error GoTo ErrorHandler
            rs.MoveNext
        Loop
        
        ' Найти максимальную дату
        If dateList.Count > 0 Then
            maxDate = dateList(1)
            For i = 2 To dateList.Count
                If dateList(i) > maxDate Then
                    maxDate = dateList(i)
                End If
            Next i

            maxDateStr = Format(maxDate, "dd.mm.yyyy")
        End If
    End If
    
    sql = "SELECT " & НаименованиеШапкиТаблицы & " FROM Information_objects WHERE cad_numb = '" & КадастровыйНомер & "' AND date_formation = '" & maxDateStr & "';"
    
    ' Выполнение запроса и получение результата
    Set rs = conn.Execute(sql)
    If Not rs.EOF Then
        resultValue = rs.Fields(0).Value
        
        ' Замена точек на запятые для указанных столбцов
        If НаименованиеШапкиТаблицы = "cost_value" Or _
           НаименованиеШапкиТаблицы = "area" Or _
           НаименованиеШапкиТаблицы = "built_up_area" Or _
           НаименованиеШапкиТаблицы = "extension" Or _
           НаименованиеШапкиТаблицы = "depth" Or _
           НаименованиеШапкиТаблицы = "occurence_depth" Or _
           НаименованиеШапкиТаблицы = "volume" Or _
           НаименованиеШапкиТаблицы = "height" Or _
           НаименованиеШапкиТаблицы = "degree_readiness" Then
            
            If Not IsNull(resultValue) Then
                Dim formattedValue As String
                formattedValue = Replace(resultValue, ".", ",")
                
                If НаименованиеШапкиТаблицы = "cost_value" Then
                    ПоискВБазе = formattedValue
                Else
                    ПоискВБазе = formattedValue ' Возвращаем отформатированное значение для других столбцов
                End If
                
            Else
                ПоискВБазе = ""
            End If
            
        Else
            If IsNull(resultValue) Or resultValue = 0 Then
                ПоискВБазе = ""
            Else
                ПоискВБазе = resultValue
            End If
        End If
        
    Else
        ПоискВБазе = ""
    End If

Cleanup:
    On Error Resume Next ' Игнорируем ошибки при закрытии объектов
    If Not rs Is Nothing Then If rs.State = 1 Then rs.Close ' Закрываем набор записей, если он открыт
    If Not conn Is Nothing Then If conn.State = 1 Then conn.Close ' Закрываем соединение, если оно открыто
    
    Exit Function

ErrorHandler:
    ПоискВБазе = "Ошибка: " & Err.Description
    Resume Cleanup

End Function

Получилось примерно так в конечном варианте, вроде работает... может и коряво написано... @Akina извини, не понимаю я... делал выше rs.MoveFirst (в первоначальном коде, а не в том который выложил), но код почему то не работал потом, бился долго и башка болела жуть как)))) в итогде сделал таблицу, где в 1 строку записал наименование столбцов из базы и отправил их вот сюда sql = "SELECT " & НаименованиеШапкиТаблицы & " FROM Information_objects WHERE cad_numb = '" & КадастровыйНомер & "' AND date_formation = '" & maxDateStr & "';" Максимальная дата нужна для поиска актуальной информации (дата выписки из ЕГРН)

→ Ссылка