Домашняя страница Undo Do New Save Карта сайта Обратная связь Поиск по форуму
МИР MS EXCEL - Гость.xls

Вход

Регистрация

Напомнить пароль

 

= Мир MS Excel/Поместить в форму результат запроса в Access - Мир MS Excel

Старая форма входа
  • Страница 1 из 1
  • 1
Модератор форума: китин, _Boroda_  
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Поместить в форму результат запроса в Access (Макросы/Sub)
Поместить в форму результат запроса в Access
ОлеггелО Дата: Пятница, 19.04.2024, 10:21 | Сообщение № 1
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 129
Репутация: 20 ±
Замечаний: 0% ±

Добрый день! Нужно результат запроса в ACCESS поместить в ListBox1 Excel минуя этап его выгрузки на лист (кажется так делать можно, но не получается). В приложенных файлах сама база данных и файл с макросом и формой. На всякий случай макрос с запросом тоже сюда выкладываю.
[vba]
Код
Sub From_Access_In_Excel() '
Application.ScreenUpdating = False
Dim dbe As Object '
Dim db  As Object '
Dim rst As Object '
Void = " & Space(1) & "

If ActiveSheet.Name = "ДляПримера" Then
    FullWay_1 = ActiveWorkbook.Path '
    FileNameBD = "DB.accdb"
    FullWay = FullWay_1 & "\" & FileNameBD
    
    Set dbe = CreateObject("DAO.DBEngine.120") '
    Set db = dbe.OpenDatabase(FullWay) '
        
        sSQL = sSQL + ""
        sSQL = "SELECT "
        sSQL = sSQL + " Фамилия " & Void & ""
        sSQL = sSQL + " Имя " & Void & ""
        sSQL = sSQL + " Отчество " & Void & ""
        sSQL = sSQL + " ДатаРождения "
        sSQL = sSQL + " FROM "
        sSQL = sSQL + " Пример "
        sSQL = sSQL + " WHERE "
        sSQL = sSQL + " ДатаРождения > 11 "
        
    Set rst = db.OpenRecordset(sSQL)
    Range("A2").CopyFromRecordset rst
End If

Set dbe = Nothing
Set db = Nothing
Set rst = Nothing

WorkForm_1.Hide
Application.ScreenUpdating = True
End Sub
[/vba]
К сообщению приложен файл: DB.accdb (476.0 Kb) · primer_dlja_access.xlsm (126.6 Kb)
 
Ответить
СообщениеДобрый день! Нужно результат запроса в ACCESS поместить в ListBox1 Excel минуя этап его выгрузки на лист (кажется так делать можно, но не получается). В приложенных файлах сама база данных и файл с макросом и формой. На всякий случай макрос с запросом тоже сюда выкладываю.
[vba]
Код
Sub From_Access_In_Excel() '
Application.ScreenUpdating = False
Dim dbe As Object '
Dim db  As Object '
Dim rst As Object '
Void = " & Space(1) & "

If ActiveSheet.Name = "ДляПримера" Then
    FullWay_1 = ActiveWorkbook.Path '
    FileNameBD = "DB.accdb"
    FullWay = FullWay_1 & "\" & FileNameBD
    
    Set dbe = CreateObject("DAO.DBEngine.120") '
    Set db = dbe.OpenDatabase(FullWay) '
        
        sSQL = sSQL + ""
        sSQL = "SELECT "
        sSQL = sSQL + " Фамилия " & Void & ""
        sSQL = sSQL + " Имя " & Void & ""
        sSQL = sSQL + " Отчество " & Void & ""
        sSQL = sSQL + " ДатаРождения "
        sSQL = sSQL + " FROM "
        sSQL = sSQL + " Пример "
        sSQL = sSQL + " WHERE "
        sSQL = sSQL + " ДатаРождения > 11 "
        
    Set rst = db.OpenRecordset(sSQL)
    Range("A2").CopyFromRecordset rst
End If

Set dbe = Nothing
Set db = Nothing
Set rst = Nothing

WorkForm_1.Hide
Application.ScreenUpdating = True
End Sub
[/vba]

Автор - ОлеггелО
Дата добавления - 19.04.2024 в 10:21
Pelena Дата: Пятница, 19.04.2024, 19:43 | Сообщение № 2
Группа: Админы
Ранг: Местный житель
Сообщений: 19187
Репутация: 4421 ±
Замечаний: ±

Excel 365 & Mac Excel
Здравствуйте.
Посмотрите, так хотели?
К сообщению приложен файл: 8943954.xlsm (26.4 Kb)


"Черт возьми, Холмс! Но как??!!"
Ю-money 41001765434816
 
Ответить
СообщениеЗдравствуйте.
Посмотрите, так хотели?

Автор - Pelena
Дата добавления - 19.04.2024 в 19:43
MikeVol Дата: Суббота, 20.04.2024, 01:12 | Сообщение № 3
Группа: Проверенные
Ранг: Обитатель
Сообщений: 315
Репутация: 61 ±
Замечаний: 0% ±

Excel LTSC 2021 EN
Елена, Доброго времени суток. Можете выложить код сюда? Пожалуйста. Пишу проект схожий как и у ОлеггелО, точнее не могу сказать так как нет возможности скачать его файлы примеры. И столкнулся с тем же вопрос. Пришлось бы мне тоже аналогичную тему создавать. На лист могу вывалить рекордсет а вот сразу из базы в ListBox нет. Спасибо вам заранее. Мира и Здоровья!

Update!
Разобрался сам. Выложу свой пример кода Пользовательской формы сюда, может кому в будущем пригодится. Но, сразу скажу что код не подойдёт для данной темы и в моём коде данные заносится и на лист и сразу заполняет ListBox1 данными из Recordset-а. Можно удалить данный блок из кода тогда останется только заполнение данными в ListBox1 непосредственно из Recordset-а. Возможно адаптация.


Ученик.

Сообщение отредактировал MikeVol - Суббота, 20.04.2024, 02:19
 
Ответить
СообщениеЕлена, Доброго времени суток. Можете выложить код сюда? Пожалуйста. Пишу проект схожий как и у ОлеггелО, точнее не могу сказать так как нет возможности скачать его файлы примеры. И столкнулся с тем же вопрос. Пришлось бы мне тоже аналогичную тему создавать. На лист могу вывалить рекордсет а вот сразу из базы в ListBox нет. Спасибо вам заранее. Мира и Здоровья!

Update!
Разобрался сам. Выложу свой пример кода Пользовательской формы сюда, может кому в будущем пригодится. Но, сразу скажу что код не подойдёт для данной темы и в моём коде данные заносится и на лист и сразу заполняет ListBox1 данными из Recordset-а. Можно удалить данный блок из кода тогда останется только заполнение данными в ListBox1 непосредственно из Recordset-а. Возможно адаптация.

Автор - MikeVol
Дата добавления - 20.04.2024 в 01:12
ОлеггелО Дата: Суббота, 20.04.2024, 06:33 | Сообщение № 4
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 129
Репутация: 20 ±
Замечаний: 0% ±

Pelena, спасибо! Это практически то, что нужно. Единственное, в Вашем коде данные в ListBox1 загружаются по столбикам (пробелы между словами длинные), нужно что бы был один пробел между словами. Но с этим, я думаю, смогу справиться сам. Спасибо ещё раз!


Сообщение отредактировал ОлеггелО - Суббота, 20.04.2024, 06:34
 
Ответить
СообщениеPelena, спасибо! Это практически то, что нужно. Единственное, в Вашем коде данные в ListBox1 загружаются по столбикам (пробелы между словами длинные), нужно что бы был один пробел между словами. Но с этим, я думаю, смогу справиться сам. Спасибо ещё раз!

Автор - ОлеггелО
Дата добавления - 20.04.2024 в 06:33
Pelena Дата: Суббота, 20.04.2024, 07:33 | Сообщение № 5
Группа: Админы
Ранг: Местный житель
Сообщений: 19187
Репутация: 4421 ±
Замечаний: ±

Excel 365 & Mac Excel
Можете выложить код сюда?

Доброе утро. Да я, собственно, использовала код из первого поста при инициализации формы

[vba]
Код
Private Sub UserForm_Initialize()
    Dim dbe As Object '
    Dim db As Object '
    Dim rst As Object '
    Void = ","
    FullWay_1 = ActiveWorkbook.Path    '
    FileNameBD = "DB.accdb"
    FullWay = FullWay_1 & "\" & FileNameBD

    Set dbe = CreateObject("DAO.DBEngine.120")    '
    Set db = dbe.OpenDatabase(FullWay)    '

    ssql = ssql + ""
    ssql = "SELECT "
    ssql = ssql + " Фамилия " & Void & ""
    ssql = ssql + " Имя " & Void & ""
    ssql = ssql + " Отчество " & Void & ""
    ssql = ssql + " ДатаРождения "
    ssql = ssql + " FROM "
    ssql = ssql + " Пример "
    ssql = ssql + " WHERE "
    ssql = ssql + " ДатаРождения > 11 "

    Set rst = db.OpenRecordset(ssql)
    With Me.ListBox1
        Do While Not rst.EOF
            If Not IsNull(rst.Fields(0)) Then
                .AddItem rst.Fields(0)
                .List(.ListCount - 1, 1) = rst.Fields(1)
                .List(.ListCount - 1, 2) = rst.Fields(2)
                .List(.ListCount - 1, 3) = rst.Fields(3)
            End If
            rst.MoveNext
        Loop
    End With

    Set dbe = Nothing
    Set db = Nothing
    Set rst = Nothing

End Sub
[/vba]


"Черт возьми, Холмс! Но как??!!"
Ю-money 41001765434816
 
Ответить
Сообщение
Можете выложить код сюда?

Доброе утро. Да я, собственно, использовала код из первого поста при инициализации формы

[vba]
Код
Private Sub UserForm_Initialize()
    Dim dbe As Object '
    Dim db As Object '
    Dim rst As Object '
    Void = ","
    FullWay_1 = ActiveWorkbook.Path    '
    FileNameBD = "DB.accdb"
    FullWay = FullWay_1 & "\" & FileNameBD

    Set dbe = CreateObject("DAO.DBEngine.120")    '
    Set db = dbe.OpenDatabase(FullWay)    '

    ssql = ssql + ""
    ssql = "SELECT "
    ssql = ssql + " Фамилия " & Void & ""
    ssql = ssql + " Имя " & Void & ""
    ssql = ssql + " Отчество " & Void & ""
    ssql = ssql + " ДатаРождения "
    ssql = ssql + " FROM "
    ssql = ssql + " Пример "
    ssql = ssql + " WHERE "
    ssql = ssql + " ДатаРождения > 11 "

    Set rst = db.OpenRecordset(ssql)
    With Me.ListBox1
        Do While Not rst.EOF
            If Not IsNull(rst.Fields(0)) Then
                .AddItem rst.Fields(0)
                .List(.ListCount - 1, 1) = rst.Fields(1)
                .List(.ListCount - 1, 2) = rst.Fields(2)
                .List(.ListCount - 1, 3) = rst.Fields(3)
            End If
            rst.MoveNext
        Loop
    End With

    Set dbe = Nothing
    Set db = Nothing
    Set rst = Nothing

End Sub
[/vba]

Автор - Pelena
Дата добавления - 20.04.2024 в 07:33
MikeVol Дата: Суббота, 20.04.2024, 11:41 | Сообщение № 6
Группа: Проверенные
Ранг: Обитатель
Сообщений: 315
Репутация: 61 ±
Замечаний: 0% ±

Excel LTSC 2021 EN
ОлеггелО, Доброго времени суток. Ещё как вариант но на основе моего кода из поста № 3
[vba]
Код
Private Sub CommandButton1_Click()
    Dim i As Long, j As Long, numCol As Long
    On Error GoTo Whoa
    Application.ScreenUpdating = False

    Dim dbPath      As String
    dbPath = ActiveWorkbook.Path & "\" & "db.accdb"

    Dim cnn         As ADODB.Connection
    Set cnn = New ADODB.Connection
    cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & dbPath

    Dim SQL         As String
    SQL = "SELECT * FROM Пример WHERE ДатаРождения >41"

    Dim rs          As ADODB.Recordset
    Set rs = New ADODB.Recordset

    rs.Open SQL, cnn

    If rs.EOF And rs.BOF Then
        rs.Close
        cnn.Close
        Set rs = Nothing
        Set cnn = Nothing
        Application.ScreenUpdating = True

        MsgBox "There are no records in the recordset!", vbCritical, "No Records"
        Exit Sub
    End If

    rs.MoveFirst
    i = 0

    With Me.ListBox1
        .ColumnWidths = "0;75,75,75,20"
        .ColumnCount = rs.Fields.Count
        .Column = rs.GetRows

        Do Until rs.EOF
            .AddItem
            numCol = rs.Fields.Count

            For j = 0 To numCol
                .List(i, j) = rs.Fields(j).Value
            Next j

            i = i + 1
            rs.MoveNext
        Loop

    End With

    Application.ScreenUpdating = True
LetsContinue:
    Application.ScreenUpdating = True
    On Error Resume Next
    rs.Close
    Set rs = Nothing
    cnn.Close
    Set cnn = Nothing
    On Error GoTo 0
    Exit Sub
Whoa:
    MsgBox "Error Description:  " & Err.Description & vbCrLf & _
            "Error at line:     " & Erl & vbCrLf & _
            "Error Number:      " & Err.Number
    Resume LetsContinue
End Sub
[/vba]
Должны быть подключены необходимые Библиотеки для правильной работы кода, смотрим скриншот ниже!

P.S. Pelena, Спасибо Вам! Мира и Здоровья!
К сообщению приложен файл: 3316199.png (25.1 Kb)


Ученик.

Сообщение отредактировал MikeVol - Суббота, 20.04.2024, 11:49
 
Ответить
СообщениеОлеггелО, Доброго времени суток. Ещё как вариант но на основе моего кода из поста № 3
[vba]
Код
Private Sub CommandButton1_Click()
    Dim i As Long, j As Long, numCol As Long
    On Error GoTo Whoa
    Application.ScreenUpdating = False

    Dim dbPath      As String
    dbPath = ActiveWorkbook.Path & "\" & "db.accdb"

    Dim cnn         As ADODB.Connection
    Set cnn = New ADODB.Connection
    cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & dbPath

    Dim SQL         As String
    SQL = "SELECT * FROM Пример WHERE ДатаРождения >41"

    Dim rs          As ADODB.Recordset
    Set rs = New ADODB.Recordset

    rs.Open SQL, cnn

    If rs.EOF And rs.BOF Then
        rs.Close
        cnn.Close
        Set rs = Nothing
        Set cnn = Nothing
        Application.ScreenUpdating = True

        MsgBox "There are no records in the recordset!", vbCritical, "No Records"
        Exit Sub
    End If

    rs.MoveFirst
    i = 0

    With Me.ListBox1
        .ColumnWidths = "0;75,75,75,20"
        .ColumnCount = rs.Fields.Count
        .Column = rs.GetRows

        Do Until rs.EOF
            .AddItem
            numCol = rs.Fields.Count

            For j = 0 To numCol
                .List(i, j) = rs.Fields(j).Value
            Next j

            i = i + 1
            rs.MoveNext
        Loop

    End With

    Application.ScreenUpdating = True
LetsContinue:
    Application.ScreenUpdating = True
    On Error Resume Next
    rs.Close
    Set rs = Nothing
    cnn.Close
    Set cnn = Nothing
    On Error GoTo 0
    Exit Sub
Whoa:
    MsgBox "Error Description:  " & Err.Description & vbCrLf & _
            "Error at line:     " & Erl & vbCrLf & _
            "Error Number:      " & Err.Number
    Resume LetsContinue
End Sub
[/vba]
Должны быть подключены необходимые Библиотеки для правильной работы кода, смотрим скриншот ниже!

P.S. Pelena, Спасибо Вам! Мира и Здоровья!

Автор - MikeVol
Дата добавления - 20.04.2024 в 11:41
ОлеггелО Дата: Суббота, 20.04.2024, 17:34 | Сообщение № 7
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 129
Репутация: 20 ±
Замечаний: 0% ±

MikeVol, спасибо и Вам! Но код сделанный Pelena для меня более понятен и, соответственно, лучше поддаётся корректировке. Pelena, скорректировал всего одну строку, а именно написал так: [vba]
Код
.List(.ListCount - 1, 0) = rst.Fields(0) & " " & rst.Fields(1) & " " & rst.Fields(2) & " " & rst.Fields(3)
[/vba] Таким образом получилось всё, что я хотел - спасибо ещё раз!
 
Ответить
СообщениеMikeVol, спасибо и Вам! Но код сделанный Pelena для меня более понятен и, соответственно, лучше поддаётся корректировке. Pelena, скорректировал всего одну строку, а именно написал так: [vba]
Код
.List(.ListCount - 1, 0) = rst.Fields(0) & " " & rst.Fields(1) & " " & rst.Fields(2) & " " & rst.Fields(3)
[/vba] Таким образом получилось всё, что я хотел - спасибо ещё раз!

Автор - ОлеггелО
Дата добавления - 20.04.2024 в 17:34
MikeVol Дата: Суббота, 20.04.2024, 23:31 | Сообщение № 8
Группа: Проверенные
Ранг: Обитатель
Сообщений: 315
Репутация: 61 ±
Замечаний: 0% ±

Excel LTSC 2021 EN
ОлеггелО, Предлагаю вместо ваших строк: [vba]
Код
    ssql = ssql + ""
    ssql = "SELECT "
    ssql = ssql + " Фамилия " & Void & ""
    ssql = ssql + " Имя " & Void & ""
    ssql = ssql + " Отчество " & Void & ""
    ssql = ssql + " ДатаРождения "
    ssql = ssql + " FROM "
    ssql = ssql + " Пример "
    ssql = ssql + " WHERE "
    ssql = ssql + " ДатаРождения > 11 "
[/vba]
Заменить одной строкой: [vba]
Код
SSQL = "SELECT * FROM Пример WHERE ДатаРождения >41"
[/vba]
Тогда у вас будет учитываться критерий для отбора ">41" и ещё вместо вашей строки: [vba]
Код
.List(.ListCount - 1, 0) = rst.Fields(0) & " "  & rst.Fields(1) & " " & rst.Fields(2) & " " & rst.Fields(3)
[/vba]
Вставить: [vba]
Код
.List(.ListCount - 1, 0) = rst.Fields(1) & " " & rst.Fields(2) & " " & rst.Fields(3) & " " & rst.Fields(4)
[/vba] Думаю вы заметите разницу. Удачи.


Ученик.
 
Ответить
СообщениеОлеггелО, Предлагаю вместо ваших строк: [vba]
Код
    ssql = ssql + ""
    ssql = "SELECT "
    ssql = ssql + " Фамилия " & Void & ""
    ssql = ssql + " Имя " & Void & ""
    ssql = ssql + " Отчество " & Void & ""
    ssql = ssql + " ДатаРождения "
    ssql = ssql + " FROM "
    ssql = ssql + " Пример "
    ssql = ssql + " WHERE "
    ssql = ssql + " ДатаРождения > 11 "
[/vba]
Заменить одной строкой: [vba]
Код
SSQL = "SELECT * FROM Пример WHERE ДатаРождения >41"
[/vba]
Тогда у вас будет учитываться критерий для отбора ">41" и ещё вместо вашей строки: [vba]
Код
.List(.ListCount - 1, 0) = rst.Fields(0) & " "  & rst.Fields(1) & " " & rst.Fields(2) & " " & rst.Fields(3)
[/vba]
Вставить: [vba]
Код
.List(.ListCount - 1, 0) = rst.Fields(1) & " " & rst.Fields(2) & " " & rst.Fields(3) & " " & rst.Fields(4)
[/vba] Думаю вы заметите разницу. Удачи.

Автор - MikeVol
Дата добавления - 20.04.2024 в 23:31
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Поместить в форму результат запроса в Access (Макросы/Sub)
  • Страница 1 из 1
  • 1
Поиск:

Яндекс.Метрика Яндекс цитирования
© 2010-2024 · Дизайн: MichaelCH · Хостинг от uCoz · При использовании материалов сайта, ссылка на www.excelworld.ru обязательна!