Zapytania SELECT na otwartyn skoroszycie ADO   strona główna:
A po co ten Excel ;-)
 
     Dziś kolejna procedura będąca gotowym narzędziem pozwalającym na wyciąganie z zestawy danych istotnego fragmentu. Ten istotny fragment okre-  
ślamy za pomocą zapytań SQL i wg. mnie to właśnie jest w całej zabawie najfajniejsze. Nieraz użytkownicy Excela trzymają całość danych w jednym  
arkuszu - służącym za "swoistą" bazę danych, a do kolejnego chcieliby tę bazę filtrować pewnymi kryteriami. Większość takich zadań można realizować  
za pomocą filtra zaawansowanego czy tabeli przestawnej. Jednak czasem SQL wydaje mi się precyzyjniejszy w określeniu zakresu danych oraz nakłada-  
nych na nie warunków, wygodny w zakresie grupowania danych czy ich złączeniach. I choć to kwestia subiektywna, SQL wydaje się nie raz po prostu  
niezastąpiony. :-)  
     Cała procedura powinna być umieszczona w module standardowym. I choć reguły umieszczenia odpowiednich fragmentów kodu w modułach wydawać  
by się mogły proste i jasne, nie tłumacząc co powinno być w części deklaracji modułu czy po niej proponuję na ten kod przeznaczyć oddzielny moduł a  
przykłady wykorzystania procedur wykorzystujących ExecuteSQLCommand_ADO wstawiać po prostu gdzie indziej (np.: w innym module standardowym)  
     Procedura więc wygląda następująco:  
 
Option Explicit   
Declare Function GetTempPath _   
                  Lib "kernel32.dll" _   
                      Alias "GetTempPathA" _   
                      (ByVal nBufferLength As Long, _   
                       ByVal lpBuffer As String) As Long   
 
Const adOpenStatic = 3   
Const adStateOpen = 1   
Const adEditNone = 0   
Const adUseClient = 3   
Const adCmdText = 1   
Const adModeRead = 1   
 
Private Sub ExecuteSQLCommand_ADO(wkbOpenedWorkBook As Excel.Workbook, _   
                                  strSQL As String, _   
                                  rngKomCel As Excel.Range, _   
                                  Optional HDR As String = "No")   
    On Error GoTo ExecuteSQLCommand_ADO_Error   
 
    Dim strTempXLSFileFullName As String   
    Dim objConnection As Object, objRecordset As Object   
 
    strTempXLSFileFullName = GetTempDirectory & "temp.xls"   
    wkbOpenedWorkBook.SaveCopyAs strTempXLSFileFullName   
      
    Set objConnection = CreateObject("ADODB.Connection")   
    With objConnection   
        .CursorLocation = adUseClient   
        .Mode = adModeRead   
        .Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _   
              "Data Source=" & strTempXLSFileFullName & ";" & _   
              "Extended Properties=""Excel 8.0;HDR=" & HDR & """"   
        Set objRecordset = .Execute(strSQL, , adCmdText)   
        With objRecordset   
            If Not (.BOF And .EOF) Then rngKomCel.CopyFromRecordset objRecordset   
        End With   
    End With   
 
ExecuteSQLCommand_ADO_Exit:   
    On Error Resume Next   
    VBA.Kill strTempXLSFileFullName   
    CloseRSObject objRecordset   
    CloseConObject objConnection   
    Exit Sub   
 
ExecuteSQLCommand_ADO_Error:   
    MsgBox "Byk nr: - " & Err.Number & vbCrLf & vbCrLf & _   
            Err.Description, vbExclamation, "VBAProject - ExeSQLComADO"   
    Resume ExecuteSQLCommand_ADO_Exit   
 
End Sub   
 
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   
 
Function GetTempDirectory() As String   
    Dim buffer As String, bufferLen As Long   
 
    buffer = Space$(256)   
    bufferLen = GetTempPath(Len(buffer), buffer)   
    If bufferLen > 0 And bufferLen < 256 Then   
        buffer = Left$(buffer, bufferLen)   
    End If   
    If InStr(buffer, Chr$(0)) <> 0 Then   
        GetTempDirectory = Left$(buffer, InStr(buffer, Chr$(0)) - 1)   
    Else   
        GetTempDirectory = buffer   
    End If   
End Function  
 
Wiele nie tłumacząc:   BUG: Memory leak occurs when you query an open Excel worksheet by using ActiveX Data Objects (ADO)
    1. procedura metodą SaveCopyAs stworzy kopię skoroszytu określonego w arg. wkbOpenedWorkBook (As Excel.Workbook) i to z niego dane zostaną  
        importowane.  
    2. plik ten zostanie zapisany w katalogu plików tymczasowych, którego ścieżka zostanie wyznaczona za pomocą funkcji GetTempDirectory, która ją  
        wyznacza za pomocą funkcji GetTempPathA (API). Po imporcie plik zostaje usunięty.   GetTempDirectory
 
Ciekawych czemu SaveCopyAs czy zainteresowanych informacjami nt. składni i przykładów zapytań SQL opartych o klauzulę SELECT zapraszam do  
lekturki mojego wątku ADO i SQL na excelforum.pl (link na prawo)   ADO i SQL
 
A teraz przykłady zapytań:  
Zadanie1  
     W Ark. Arkusz1 od C2 do ostatniej wypełnionej komórki w kol.C mamy liczby które mogą się powtarzać. Dane nie posiadają nagłówka. Jak wyciągnąć  
od kom.E2 unikatowe liczby w kol.C a obok tych liczb wpisać ile razy dana liczba wystąpiła. Dane te należy przedstawić w kolejności od najczęściej do  
najrzadziej występujących.  
 
Sub WartościNajczęściejWystępująceWKolumnie()  
    Dim wks As Excel.Worksheet, ostC As Long  
    Dim strSQL As String  
      
    Set wks = ThisWorkbook.Worksheets("Arkusz1")  
    With wks  
        ostC = Last(.Columns("C"))  
        If ostC > 2 Then  
          
            strSQL = "SELECT DISTINCT(F1), COUNT(F1) " & _  
                     "FROM [Arkusz1$C2:C" & ostC & "] " & _  
                     "GROUP BY F1 " & _  
                     "ORDER BY COUNT(F1) DESC;"  
      
            ExecuteSQLCommand_ADO .Parent, strSQL, .[E2]  
         
        End If  
    End With  
    Set wks = Nothing  
End Sub  
 
Function Last(rng As Excel.Range) As Long   
    ' wg. Ron de Bruin, 20 Feb 2007   
    ' http://www.rondebruin.nl/last.htm   
    On Error Resume Next   
    Last = rng.Find(What:="*", _   
                    After:=rng.Cells(1), _   
                    Lookat:=xlPart, _   
                    LookIn:=xlFormulas, _   
                    SearchOrder:=xlByRows, _   
                    SearchDirection:=xlPrevious, _   
                    MatchCase:=False).Row   
    On Error GoTo 0   
End Function   
 
 
Zadanie2  
W Ark.Zbiór w kolumnach A:C mamy dane z nagłówkami: Nr, Rok, Suma. W Ark.warunke w kol.A są dane o nagłówku Nr. oraz w kom. E1 - rok.  
Zadanie polega na zgrupowaniu danych z Ark.Zbiór na podstawie kolumn Nr i Rok sumując dane z kol.Suma jednak zestaw zwróconych danych należy   Link do przykładu
zawężyć tylko do tych danych których Nr występuje w kol.Nr Ark.warunek oraz z roku wskazanego w kom.E1 Ark.warunek.  
    Zadanie można wykonać tworząc złączenie zewnętrzne na dwóch zakresach danych w tym samym pliku.   
 
Sub Grupowanie_danych()  
    Dim wks As Excel.Worksheet, wks2 As Excel.Worksheet  
    Dim strSQL As String  
      
    With ThisWorkbook  
        Set wks = .Worksheets("wynik")  
        Set wks2 = .Worksheets("warunek")  
    End With  
      
    strSQL = "SELECT A.[Nr], A.[Rok], SUM(A.[Suma]) " & _  
             "FROM [Zbiór$A:C] AS A " & _  
             "RIGHT OUTER JOIN [warunek$A:A] AS B " & _  
             "ON A.[Nr] = B.[Nr] " & _  
             "GROUP BY A.[Nr], A.[Rok] " & _  
             "HAVING A.[Rok] = " & wks2.[E1] & ";"  
 
    ExecuteSQLCommand_ADO wks.Parent, strSQL, wks.[A2], "Yes"  
              
    Set wks2 = Nothing  
    Set wks = Nothing  
End Sub  
 
Jak wykorzystam jeszcze w jakimś ciekawym temacie zaktualizuję stronę :-)