Option Explicit
Dim dbFileName
Dim curQuery As String

Private Sub CommandButton1_Click()
Dim cn As ADODB.Connection
Dim rst As ADODB.Recordset

    dbFileName = Application.GetOpenFilename _
        ("Access Files (*.accdb), *.accdb")
    If dbFileName = False Then Exit Sub

    Set cn = New ADODB.Connection
    cn.ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
            "Data Source=" & dbFileName & ";Mode=Read"
    On Error Resume Next
    cn.Open

    If cn.State = 1 Then
        ListBox1.Clear
        Set rst = New ADODB.Recordset
        Set rst = cn.OpenSchema(adSchemaTables)
        rst.MoveFirst
        Do While Not rst.EOF
            If rst.Fields.Item("TABLE_TYPE") = "TABLE" Then
                ListBox1.AddItem rst.Fields.Item("TABLE_NAME")
            End If
            rst.MoveNext
        Loop
        rst.Close
        Set rst = Nothing
    Else
        MsgBox "Не удается подключиться к базе" & vbCr & dbFileName
        dbFileName = False
    End If
    cn.Close
    Set cn = Nothing
    Label1.Caption = dbFileName
End Sub

Private Sub CommandButton2_Click()
Dim cn As ADODB.Connection
Dim rst As ADODB.Recordset

    Set cn = New ADODB.Connection
    Set rst = New ADODB.Recordset

    cn.ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
            "Data Source=" & dbFileName & ";Mode=Read"
    cn.Open
    rst.Open curQuery, cn
    Cells.ClearContents
    Cells.NumberFormat = "General"
    ActiveSheet.Range("A2").CopyFromRecordset rst
    Cells.Columns.AutoFit
    rst.Close
    cn.Close
    Set rst = Nothing
    Set cn = Nothing
End Sub

Private Sub ListBox1_Click()
Dim cn As ADODB.Connection
Dim rst As ADODB.Recordset
Dim curTable As String
Dim i As Integer
Dim curField

    Set cn = New ADODB.Connection
    Set rst = New ADODB.Recordset

    cn.ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
            "Data Source=" & dbFileName & ";Mode=Read"
    On Error Resume Next
    cn.Open
    If cn.State = 1 Then
        curTable = ListBox1.List(ListBox1.ListIndex)
        ListBox2.Clear
        ListBox2.ColumnWidths = "100,140"
        rst.LockType = adLockOptimistic
        rst.Open "SELECT  * FROM [" & curTable & "]", cn
        For Each curField In rst.Fields
            ListBox2.AddItem
            ListBox2.List(ListBox2.ListCount - 1, 0) = curField.Name
            ListBox2.List(ListBox2.ListCount - 1, 1) = ""
        Next curField
        'MsgBox rst.RecordCount
        rst.MoveFirst
        i = 0
        Do While Not rst.EOF
            i = i + 1
            rst.MoveNext
        Loop
        Label2.Caption = "Кол-во записей :" & vbCr & i
        rst.Close
    End If
    cn.Close
    Set rst = Nothing
    Set cn = Nothing
    TextBox1.Value = ""

End Sub

Private Sub ListBox2_Change()
Dim i As Integer
Dim fieldsList As String
Dim curTable As String


    fieldsList = ""
    curTable = ListBox1.List(ListBox1.ListIndex)
    For i = 0 To ListBox2.ListCount - 1
        If ListBox2.Selected(i) Then
            fieldsList = _
                fieldsList & "[" & curTable & "." & ListBox2.List(i) & "], "
        End If
    Next i
    If fieldsList <> "" Then
        fieldsList = Trim(Left(fieldsList, Len(fieldsList) - 2))
        curQuery = "SELECT " & fieldsList & " FROM [" & curTable & "]"
        TextBox1.Value = curQuery
    Else
        TextBox1.Value = ""
    End If
End Sub

Private Sub ListBox2_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Dim curCondition As String
Dim curFieldName As String
Dim curPrompt As String

    If Button = 2 Then
        curCondition = ListBox2.List(ListBox2.ListIndex, 1)
        curFieldName = ListBox2.List(ListBox2.ListIndex, 0)
        curPrompt = "Изменить условие отбора для поля " & curFieldName & " ?"
        curCondition = InputBox(curPrompt, , curCondition)
        If curCondition <> "" Then
            ListBox2.List(ListBox2.ListIndex, 1) = curCondition
        End If
    End If
End Sub