Funkcja SelectFromXls_ADO zwracająca dane z plików Excela przez ADO sykorzystując składnie SQL   strona główna:
A po co ten Excel ;-)
 
Już dawno miałem ją napisać ;-) i w końcu jest..  
Funkcja ma zwracać tablicę danych pochodzacych z jakiegoś zakresu lub pojedyńczej komórki zamkniętego pliku xls*.  
Należy podać w jej argumentach zapytanie SQL z Kaluzulą SELECT i ściezkę do pliku xls*.  
 
np.: =SelectFromXLS_ADO("SELECT Last(F1) FROM [Arkusz1$E:E]";"C:\Users\MiTKuchta\Desktop\Zeszyt1.xlsx")  
zwracająca ostatnią wartość z kol.E, lub np.:  
 =SelectFromXLS_ADO("SELECT F1 FROM [Arkusz1$E:E]";"C:\Users\MiTKuchta\Desktop\Zeszyt1.xlsx") tablicowo  
zwracająca dane z całego zakresu.  
 
 
Option Explicit  
 
Const adUseClient = 3  
Const adModeRead = 1  
Const adCmdText = 1  
Const adStateOpen = 1  
Const adEditNone = 0  
      
Public Function SelectFromXLS_ADO(strSQL As String, strXLSFileFullName As String) As Variant  
                                          
    On Error GoTo SelectFromXLS_ADO_Error  
    Dim objConnection As Object, objRecordset As Object  
                      
    Set objConnection = CreateObject("ADODB.Connection")  
    With objConnection  
        .CursorLocation = adUseClient  
        .Mode = adModeRead  
        .Open XLSConnectionString(strXLSFileFullName, "No", 1)  
        Set objRecordset = .Execute(strSQL, , adCmdText)  
        With objRecordset  
            If Not (.BOF And .EOF) Then  
                SelectFromXLS_ADO = Transponuj2(.getRows)  
            End If  
        End With  
    End With  
                      
SelectFromXLS_ADO_Exit:  
    On Error Resume Next  
    CloseRSObject objRecordset  
    CloseConObject objConnection  
    Exit Function  
                      
SelectFromXLS_ADO_Error:  
    'MsgBox "Byk nr: - " & Err.Number & vbCrLf & vbCrLf & _  
    '        Err.Description, vbExclamation, "VBAProject - SelectFromXLS_ADO"  
    Resume SelectFromXLS_ADO_Exit  
                  
End Function  
      
Public Sub CloseConObject(Cnn As Object)  
    If Not (Cnn Is Nothing) Then  
        If Cnn.State = adStateOpen Then Cnn.Close  
        Set Cnn = Nothing  
    End If  
End Sub  
              
Public Sub CloseRSObject(Rs As Object)  
    If Not (Rs Is Nothing) Then  
        With Rs  
            If CBool(.State And adStateOpen) Then  
                If .EditMode <> adEditNone Then .CancelUpdate  
                .Close  
            End If  
        End With  
        Set Rs = Nothing  
    End If  
End Sub  
 
Public Function Transponuj2(tabl As Variant) As Variant  
    'http://www.apocotenexcel.pl/transponuj.htm  
      
    Dim X As Long, Y As Long  
    Dim Max2 As Long, Max1 As Long  
    Dim Min2 As Long, Min1 As Long  
      
    Min1 = LBound(tabl, 1): Max1 = UBound(tabl, 1)  
    Min2 = LBound(tabl, 2): Max2 = UBound(tabl, 2)  
      
    ReDim tempTabl(Min2 To Max2, Min1 To Max1)  
    For X = Min2 To Max2  
        For Y = Min1 To Max1  
            tempTabl(X, Y) = tabl(Y, X)  
        Next Y  
    Next X  
      
    Transponuj2 = tempTabl  
End Function  
 
Public Function XLSConnectionString(strXLSFileFullName As String, _  
                                    Optional HDR As String = "Yes", _  
                                    Optional IMEX As Integer = 0) As String  
    'http://www.apocotenexcel.pl/xlsconstr.htm  
      
    Dim strExtension As String  
    Dim strConnString As String, strProvider As String, strExtProp As String  
              
    strExtension = Right(strXLSFileFullName, _  
                         Len(strXLSFileFullName) - _  
                            InStrRev(strXLSFileFullName, _  
                            ".", _  
                            Len(strXLSFileFullName)))  
    Select Case Len(strExtension)  
        Case 3  
            Select Case Val(Application.Version)  
                Case Is > 11  
                    ' ---------------'E2007-E2010---------------  
                    'Excel 97-2003 Xls files with ACE OLEDB 12.0  
                    'http://www.connectionstrings.com/excel#p84  
                    strProvider = "Microsoft.ACE.OLEDB.12.0"  
                    strExtProp = "Excel 12.0"  
                              
                Case Is <= 11  
                    '    Connection strings for Excel 2007  
                    'http://www.connectionstrings.com/excel-2007  
                              
                    strProvider = "Microsoft.Jet.OLEDB.4.0"  
                    strExtProp = "Excel 8.0"  
            End Select  
                      
        Case 4  
            strProvider = "Microsoft.ACE.OLEDB.12.0"  
            Select Case strExtension  
                '    Connection strings for Excel 2007  
                'http://www.connectionstrings.com/excel-2007  
                          
                Case "xlsx": strExtProp = "Excel 12.0 Xml"  
                Case "xlsm": strExtProp = "Excel 12.0 Macro"  
                Case "xlsb": strExtProp = "Excel 12.0"  
            End Select  
    End Select  
              
    XLSConnectionString = "Provider=" & strProvider & ";" & _  
                          "Data Source=" & strXLSFileFullName & ";" & _  
                          "Extended Properties=""" & strExtProp & ";" & _  
                                               "HDR=" & HDR & ";" & _  
                                               "IMEX=" & IMEX & """"  
End Function