SQL w Excelu Cz.2: zależne listy rozwijane, walidacja (dependent lists)

W jednej z zakładek (albo w zewnętrznym pliku) posiadamy bazę produktów. W pierwszej kolumnie posiadamy kategorię nadrzędną (major), w drugiej kategorię podrzędną (minor) a w trzeciej kody konkretnych produktów, pozostałe zaś zawierają opisy, ceny, etc.

Chcielibyśmy aby w kolejnej zakładce (np. faktura proforma, oferta) wybór w pierwszej zakładce z listy rozwijanej (walidacja w Excelu) zawierał posortowaną listę występujących kategorii nadrzędnych. Wybór kategorii nadrzędnej ma spowodować rozwinięcie w sąsiedniej komórce listy kategorii podrzędnych tylko tych, które należą do kat. nadrzędnej. Z kolei wybór kategorii podrzędnej ma spowodować rozwinięcie w sąsiedniej komórce kodów. Tylko tych kodów, które należą do wybranej kat. podrzędnej. Wybór kodu ma wypełnić pozostałe sąsiadujące komórki informacją o cenie, opisem etc. ...

Konieczne jest zainstalowanie Access Runtime i dołączenie referencji do Microsoft ActiveX Data (łatwe i za darmo, patrz cz.1)

Oto propozycja rozwiązania w VBA:

W kodzie aktywującym (trigger) makra związane z wykonywanymi operacjami na arkuszu należy wprowadzić następujące makro (należy kliknąć prawym przyciskiem myszy na zakładkę arkusza z naszą fakturą proformą i wybrać z wyświetlonego menu "View Code"):

Private Sub Worksheet_Change(ByVal Target As Range)
    
    If Not Intersect(Target, Me.Range("Table1[Major]")) Is Nothing Then
            DependentLists1
    
    ElseIf Not Intersect(Target, Me.Range("Table1[Minor]")) Is Nothing Then
            DependentLists2
    ElseIf Not Intersect(Target, Me.Range("Table1[Code]")) Is Nothing Then
            DependentLists3
    Else
        Exit Sub
         
    End If

End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Not Intersect(Target, Me.Range("Table1[Major]")) Is Nothing Then
            DependentLists0
    ElseIf Not Intersect(Target, Me.Range("Table1[Minor]")) Is Nothing Then
            GoLeftOnEmpty
    ElseIf Not Intersect(Target, Me.Range("Table1[Code]")) Is Nothing Then
            GoLeftOnEmpty
        
    End If
    
End Sub




Sub GoLeftOnEmpty()

 

 'If empty cell, go back higher up.
                    If ActiveCell.Offset(0, -1).Value = "" And ActiveCell.ListObject.ListColumns.Count <> 1 Then
                        Cells(ActiveCell.Row, Range("Table1[Major]").Column).Activate
                        Exit Sub
                    End If
End Sub

A teraz posłużymy się schematem z Cz1. Bazę produktów będziemy odpytywać prostymi zapytaniami SQL i zwracać wynik do listy walidacyjnej Excela. W nowym module kodu VBA należy wprowadzić dla listy rozwijanej w pierwszej kolumnie:

Sub DependentLists0()

On Error Resume Next


Dim Myconnection As Connection
Dim Myrecordset As Recordset
Dim Myworkbook, strSQL, DataStr As String

Set Myconnection = New Connection
Set Myrecordset = New Recordset
  
Application.ScreenUpdating = False


  
'Identify the workbook you are referencing
    Myworkbook = Application.ThisWorkbook.FullName

'Open connection to the workbook
    Myconnection.Open "Provider=Microsoft.ACE.OLEDB.12.0;" & _
                      "Data Source=" & Myworkbook & ";" & _
                      "Extended Properties=Excel 8.0;" & _
                      "Persist Security Info=False"
                      

'edytuj
 
    strSQL = "SELECT DISTINCT [MajorName] " & _
             "FROM [Data$]  " & _
             "ORDER BY 1 ASC"
  

'Load the Query into a Recordset
    Myrecordset.Open strSQL, Myconnection, adOpenStatic

'Load Recordset to string variable

DataStr = Myrecordset.GetString(, , , ",", "") 'Options: StringFormat np. adClipString, NumRows, ColumnDelimiter, RowDelimiter, NullExpr

'Change validation for one cell left
 
 
With Selection.Validation
        .Delete
        .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
        xlBetween, Formula1:=DataStr
        .IgnoreBlank = True
        .InCellDropdown = True
        .InputTitle = ""
        .ErrorTitle = ""
        .InputMessage = ""
        .ErrorMessage = ""
        .ShowInput = True
        .ShowError = True
    End With
Application.SendKeys ("%{DOWN}")
   
   
'Remove Garbage
   Set Myrecordset = Nothing
   Myconnection.Close
   Application.ScreenUpdating = True


        
End Sub
        

Zaś w nowym module kodu VBA wkleić kod dla listy rozwijanej w drugiej kolumnie:

Sub DependentLists1()

On Error Resume Next


Dim Myconnection As Connection
Dim Myrecordset As Recordset
Dim Myworkbook, strSQL, DataStr As String

Set Myconnection = New Connection
Set Myrecordset = New Recordset
  
Application.ScreenUpdating = False
  
'Identify the workbook you are referencing
    Myworkbook = Application.ThisWorkbook.FullName

'Open connection to the workbook



   Myconnection.Open "Provider=Microsoft.ACE.OLEDB.12.0;" & _
                      "Data Source=" & Myworkbook & ";" & _
                      "Extended Properties=Excel 8.0;" & _
                      "Persist Security Info=False"
                      

'Build SQL Statement
        
    strSQL = "SELECT DISTINCT [MinorName] " & _
             "FROM [Data$]  " & _
             "WHERE [MajorName] =  '" & ActiveCell.Value & "'  " & _
             "ORDER BY 1 ASC"
  

'Load the Query into a Recordset
    Myrecordset.Open strSQL, Myconnection, adOpenStatic

'Load Recordset to string variable

DataStr = Myrecordset.GetString(, , , ",", "") 'Options: StringFormat np. adClipString, NumRows, ColumnDelimiter, RowDelimiter, NullExpr

'Change validation for one cell left
 
ActiveCell.Offset(0, 1).Select

 
 With Selection.Validation
            .Delete
            .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
            xlBetween, Formula1:=DataStr
            .IgnoreBlank = True
            .InCellDropdown = True
            .InputTitle = ""
            .ErrorTitle = ""
            .InputMessage = ""
            .ErrorMessage = ""
            .ShowInput = True
            .ShowError = True

End With

Application.SendKeys ("%{DOWN}")
   
   
'Remove Garbage
   Set Myrecordset = Nothing
   Myconnection.Close

Application.ScreenUpdating = True
        
End Sub
                                                

Dla list rozwijanych w trzeciej kolumnie: 

Sub DependentLists2()

On Error Resume Next


Dim Myconnection As Connection
Dim Myrecordset As Recordset
Dim Myworkbook, strSQL, DataStr As String

Set Myconnection = New Connection
Set Myrecordset = New Recordset
  
Application.ScreenUpdating = False
  
'Identify the workbook you are referencing
    Myworkbook = Application.ThisWorkbook.FullName

'Open connection to the workbook

   Myconnection.Open "Provider=Microsoft.ACE.OLEDB.12.0;" & _
                      "Data Source=" & Myworkbook & ";" & _
                      "Extended Properties=Excel 8.0;" & _
                      "Persist Security Info=False"
                      


'Build SQL Statement
        
    strSQL = "SELECT DISTINCT [Code] " & _
             "FROM [Data$]  " & _
             "WHERE [MinorName] =  '" & ActiveCell.Value & "'  " & _
             "ORDER BY 1 ASC"
  

'Load the Query into a Recordset
    Myrecordset.Open strSQL, Myconnection, adOpenStatic

'Load Recordset to string variable

DataStr = Myrecordset.GetString(, , , ",", "") 'Options: StringFormat np. adClipString, NumRows, ColumnDelimiter, RowDelimiter, NullExpr

'Change validation for one cell left
 
ActiveCell.Offset(0, 1).Select
 
 With Selection.Validation
            .Delete
            .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
            xlBetween, Formula1:=DataStr
            .IgnoreBlank = True
            .InCellDropdown = True
            .InputTitle = ""
            .ErrorTitle = ""
            .InputMessage = ""
            .ErrorMessage = ""
            .ShowInput = True
            .ShowError = True
  End With

Application.SendKeys ("%{DOWN}")
   
   
'Remove Garbage
   Set Myrecordset = Nothing
   Myconnection.Close

Application.ScreenUpdating = True
        
End Sub

Dla wypełnienia pozostałych kolumn poslużymy się zaś takim kodem: 

Sub DependentLists3()

Dim Myconnection As Connection
Dim Myrecordset As Recordset
Dim Myworkbook, strSQL, DataStr1, DataStr2 As String
Dim DataVal1 As Single


Set Myconnection = New Connection
Set Myrecordset = New Recordset
  
Application.ScreenUpdating = False
  
  
  
'Identify the workbook you are referencing
    Myworkbook = Application.ThisWorkbook.FullName
    
    

'Open connection to the workbook

   Myconnection.Open "Provider=Microsoft.ACE.OLEDB.12.0;" & _
                      "Data Source=" & Myworkbook & ";" & _
                      "Extended Properties=Excel 8.0;" & _
                      "Persist Security Info=False"
                      


'Build SQL Statement
        
    strSQL = "SELECT DISTINCT [Desc_1], [Desc_2],[Value]" & _
             "FROM [Data$]  " & _
             "WHERE [Code] =  '" & ActiveCell.Value & "'  " & _
             "ORDER BY 1 ASC"
  

'Load the Query into a Recordset
    Myrecordset.Open strSQL, Myconnection, adOpenStatic

'Load Recordset to variables

DataStr1 = IIf(IsNull(Myrecordset.Fields("Desc_1").Value), "n/a", Myrecordset.Fields("Desc_1").Value)
DataStr2 = IIf(IsNull(Myrecordset.Fields("Desc_2").Value), "n/a", Myrecordset.Fields("Desc_2").Value)
DataVal1 = IIf(IsNull(Myrecordset.Fields("Value").Value), "n/a", Myrecordset.Fields("Value").Value)

'Change validation for one cell left
 
ActiveCell.Offset(0, 1).Value = DataStr1
ActiveCell.Offset(0, 2).Value = DataStr2
ActiveCell.Offset(0, 3).Value = DataVal1
   
'Remove Garbage
   Set Myrecordset = Nothing
   Myconnection.Close

Application.ScreenUpdating = True
        
End Sub 

Przykładowy plik tutaj.