Sub GetExcel(strSourceFile As String, strSQL As String, ByRef Massiv() As Variant)
Dim cn As ADODB.Connection
Dim rstTemp As ADODB.Recordset

Set cn = New ADODB.Connection
cn.Open "DRIVER={Microsoft Excel Driver (*.xls)};DriverId=790;ReadOnly=True;" & "DBQ=" & strSourceFile & ";"
Set rstTemp = New ADODB.Recordset

rstTemp.Open strSQL, cn, adOpenForwardOnly, adLockReadOnly, adCmdText

Erase Massiv
    x =  1 
    y =  0 
    With rstTemp
        Do While Not .EOF
                     .MoveNext
                      x = x +  1 
                      If Not (.EOF) And x =  2  Then
                    
                        On Error GoTo MyLa
                            For i =  0  To  256 
                            If Not IsNull(.Fields(i)) Then y = y +  1 
                            Next i
MyLa:

                      End If
            Loop
    End With

ReDim Massiv( 1  To x,  1  To y) As Variant

rstTemp.MoveFirst
                For i =  0  To y -  1 
                Massiv( 1 , i +  1 ) = rstTemp.Fields(i).Name
                Next i
            
            For j =  0  To x -  2 
                For i =  0  To y -  1 
                Massiv(j +  2 , i +  1 ) = rstTemp.Fields(i)
                Next i
            rstTemp.MoveNext
            Next j

rstTemp.Close
cn.Close

Set rstTemp = Nothing
Set cn = Nothing

End Sub


Sub DOIT()
Dim strSourceFile As String, strSQL As String, Massiv() As Variant
strSourceFile = "E:\Test\1.xls"
strSQL = "SELECT * FROM `Лист1$`;"

Call GetExcel(strSourceFile, strSQL, Massiv)

For i =  1  To UBound(Massiv,  1 )
    For j =  1  To UBound(Massiv,  2 )
        Sheets( 1 ).Cells(i, j) = Massiv(i, j)
    Next j
Next i

End Sub