Как в 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 & "';"
Максимальная дата нужна для поиска актуальной информации (дата выписки из ЕГРН)