Sub ЗАПРОС()
' It will copy the Header row also (the last two arguments are True)
' Change the last argument to False if you not want to copy the header row
    
 ' СНИМАЕМ  ЗАЩИТУ ЛИСТА
 ActiveSheet.Unprotect Password:="591777"
 
    GetData ThisWorkbook.Path & "\БАЗА_ДАННЫХ1.xls", "Лист1", _
            "A1:F6500", Sheets("Лист1").Range("A1"), True, True
  ' СТАВИМ ЗАЩИТУ НА ЛИСТ
ActiveSheet.Protect Password:="591777", DrawingObjects:=True, Contents:=True, Scenarios:=True

End Sub


Public Sub GetData(SourceFile As Variant, SourceSheet As String, _
                   SourceRange As String, TargetRange As Range, Header As Boolean, UseHeaderRow As Boolean)
' 30-Dec-2007, working in Excel 2000-2007
    Dim rsCon As Object
    Dim rsData As Object
    Dim szConnect As String
    Dim szSQL As String
    Dim lCount As Long

    ' Create the connection string.
    If Header = False Then
        If Val(Application.Version) <  12  Then
            szConnect = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
                        "Data Source=" & SourceFile & ";" & _
                        "Extended Properties=""Excel 8.0;HDR=No"";"
        Else
            szConnect = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
                        "Data Source=" & SourceFile & ";" & _
                        "Extended Properties=""Excel 12.0;HDR=No"";"
        End If
    Else
        If Val(Application.Version) <  12  Then
            szConnect = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
                        "Data Source=" & SourceFile & ";" & _
                        "Extended Properties=""Excel 8.0;HDR=Yes"";"
        Else
            szConnect = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
                        "Data Source=" & SourceFile & ";" & _
                        "Extended Properties=""Excel 12.0;HDR=Yes"";"
        End If
    End If

    If SourceSheet = "" Then
        ' workbook level name
        szSQL = "SELECT * FROM " & SourceRange$ & ";"
    Else
        ' worksheet level name or range
        szSQL = "SELECT * FROM [" & SourceSheet$ & "$" & SourceRange$ & "];"
    End If

   ' On Error GoTo SomethingWrong

    Set rsCon = CreateObject("ADODB.Connection")
    Set rsData = CreateObject("ADODB.Recordset")

    rsCon.Open szConnect
    rsData.Open szSQL, rsCon,  0 ,  1 ,  1 

    ' Check to make sure we received data and copy the data
    If Not rsData.EOF Then

        If Header = False Then
            TargetRange.Cells( 1 ,  1 ).CopyFromRecordset rsData
        Else
            'Add the header cell in each column if the last argument is True
            If UseHeaderRow Then
                For lCount =  0  To rsData.Fields.Count -  1 
                    TargetRange.Cells( 1 ,  1  + lCount).Value = _
                    rsData.Fields(lCount).Name
                Next lCount
                TargetRange.Cells( 2 ,  1 ).CopyFromRecordset rsData
            Else
                TargetRange.Cells( 1 ,  1 ).CopyFromRecordset rsData
            End If
        End If

    Else
        MsgBox "No records returned from : " & SourceFile, vbCritical
    End If
    
UserForm1.Show

'НЕ ПОЛУЧАЕТСЯ ВСТАВИТЬ ДАННЫЕ
UserForm1.ListBox1.List = rsData

    ' Clean up our Recordset object.
    rsData.Close
    Set rsData = Nothing
    rsCon.Close
    Set rsCon = Nothing
    Exit Sub

SomethingWrong:
    MsgBox "The file name, Sheet name or Range is invalid of : " & SourceFile, _
           vbExclamation, "Error"
    On Error GoTo  0 

End Sub

UserForm1.ListBox1.List = rsData