Excel jako we/wy dla programu w C# - przykład

Bardzo ciekawy prosty przykład użycia Excela jako interfejsu dla programu w C#. Od tego przykładu można zacząć poważną zabawę :-) http://mikejuniperhill.blogspot.com/2014/03/using-excel-as-io-for-c-with-exceldna.html
Warto równiez spojrzeć tutaj: https://sysmod.wordpress.com/2012/02/06/from-vba-to-vb-net-using-exceldna/ 

Wykresy na mapie Polski w VBA

Obejrzałem bardzo ciekawą prezentację nt. tworzenia wykresów na mapie Polski. https://www.youtube.com/watch?v=sURKmfpDujE

Poniżej wersja VBA, która znalazła się w moich narzędziach. Przyznaję, że jest to zlepek wielu makr i efekt moich mniej lub bardziej świadomych eksperymentów. Na razie działa ale pewno wymaga udoskonaleń.
W pliku Excel mam dwie zakładki "DaneDoMapy" i "Map"
Na podstawie danych do mapy  (tabelka z kolumną x z nazwą dla każdego wykresu i np. dwie kolumny danych do wykresu słupkowego w każdym województwie) zostaną stworzone wykresy słupkowe i umieszczone we właściwym miejscu na mapie.

Sub main()
Sub main()
   'variable declaration
    Dim i As Long
    Dim LastRow As Long
    Dim LastColumn As Long
    Dim chrt As Chart
    Dim MaxValue As Double
    Dim ChartName As Style
    
   
    
     'Clean Sheet
    Sheets("Wykresy").DrawingObjects.Delete

    'Find the last used row
    LastRow = Sheets("DaneDoMapy").Range("A65536").End(xlUp).Row

    'Find the last used column
    LastColumn = Sheets("DaneDoMapy").Range("A1").End(xlToRight).Column

    'Find MaxValue
    MaxValue = 1.4 * Application.WorksheetFunction.Max(Sheets("DaneDoMapy").UsedRange)

    


    'Looping from second row till last row which has the data
    For i = 2 To LastRow
    

        
        'Sheet 2 is selected bcoz charts will be inserted here
        Sheets("Wykresy").Activate

        'Adds chart to the sheet
        Set chrt = Sheets("Wykresy").Shapes.AddChart.Chart
        
        
        'sets the chart type
        With chrt
             .ChartType = xlColumnClustered
             .Axes(xlValue).MajorGridlines.Delete
             .Axes(xlValue).Delete
             .Legend.Delete
             .PlotArea.Fill.Visible = False

       '      .Axes(xlCategory).Delete
 

        'scale
             .Axes(xlValue).MinimumScale = 0
             .Axes(xlValue).MaximumScale = MaxValue
            
        'size
             .Parent.Height = 100 ' resize 2.5 pt at 72 ppi.
             .Parent.Width = 45 ' resize 4.0 pt at 72 ppi.
             
  

        End With




        'now the line chart is added...setting its data source here
        With Sheets("DaneDoMapy")
            chrt.SetSourceData Source:=.Range(.Cells(i, 1), .Cells(i, LastColumn))
            chrt.Parent.Name = Left(Worksheets("DaneDoMapy").Cells(i, 1).Text, 3)
        End With

        'Left & top are used to adjust the position of chart on sheet
        chrt.ChartArea.Left = 1
        chrt.ChartArea.Top = (i - 2) * chrt.ChartArea.Height

        'Last adjustments to chart
        With chrt
            .ChartTitle.Font.Size = 7
            .ChartTitle.Font.Bold = True
            .ChartTitle.Font.Name = "Tahoma"
          '  .ChartTitle.Left = -(.ChartTitle.Left / 2)
             .ChartTitle.Top = -7 '-(.Parent.Height / 2)
    
  
        
        
        End With
  
  'set x axis
  
        
    With Sheets("DaneDoMapy")
       chrt.SeriesCollection(1).XValues = .Range(.Cells(1, 2), .Cells(1, LastColumn))
       chrt.Axes(xlCategory).TickLabels.Font.Name = "Arial Narrow"
       chrt.Axes(xlCategory).TickLabels.Font.Size = 6
       chrt.Axes(xlCategory).TickLabels.Orientation = 0
    End With
        
  'Change colors
               With chrt.SeriesCollection(1)
                         
                         .Points(1).Interior.Color = RGB(0, 0, 255)
                         .Points(2).Interior.Color = RGB(255, 0, 0)


                End With


        
        
        Next

 '       AddDataLabels_All
        FormatShapes
        PlaceOnMap
        AddDataLabels_All
End Sub






Sub FormatShapes()
    
         Dim iChtIx As Long, iChtCt As Long


         iChtCt = ActiveSheet.Shapes.Count
         For iChtIx = 1 To iChtCt
             With ActiveSheet.Shapes(iChtIx)
                .Fill.Visible = msoFalse
                .Line.Visible = msoFalse
             End With
         Next
End Sub





Sub AddDataLabels_All()

    Dim sr As Series
    Dim ws As Worksheet
    Dim chtObj As ChartObject

    Set ws = Worksheets("Map")
        For Each chtObj In ws.ChartObjects
            For Each sr In chtObj.Chart.SeriesCollection

                sr.ApplyDataLabels
                With sr.DataLabels
                    .ShowSeriesName = False
                    .ShowValue = True
                    .Position = xlLabelPositionOutsideEnd
                    .Orientation = 90
                    .Font.Size = 7
                    .Font.Name = "Tahoma"
                    .NumberFormat = "#,##0.00,, \m" '"# ###.#, k" - if in thousands
                End With

            Next sr
       Next chtObj

End Sub


Sub PlaceOnMap()


Sheets("Map").Activate
'Sheets("Map").DrawingObjects.Delete

On Error Resume Next

Sheets("Map").ChartObjects("BIA").Delete
Sheets("Map").ChartObjects("BYD").Delete
Sheets("Map").ChartObjects("GDA").Delete
Sheets("Map").ChartObjects("GOW").Delete
Sheets("Map").ChartObjects("KAT").Delete
Sheets("Map").ChartObjects("KIE").Delete
Sheets("Map").ChartObjects("KRA").Delete
Sheets("Map").ChartObjects("LDZ").Delete
Sheets("Map").ChartObjects("LUB").Delete
Sheets("Map").ChartObjects("OLS").Delete
Sheets("Map").ChartObjects("OPO").Delete
Sheets("Map").ChartObjects("POZ").Delete
Sheets("Map").ChartObjects("RZE").Delete
Sheets("Map").ChartObjects("SZC").Delete
Sheets("Map").ChartObjects("WAW").Delete
Sheets("Map").ChartObjects("WRO").Delete

    Sheets("Wykresy").ChartObjects("BIA").Cut
    Sheets("Map").Paste

    With Sheets("Map").Shapes("BIA")
        .Left = 410
        .Top = 70

    End With

    Sheets("Wykresy").ChartObjects("BYD").Cut
    Sheets("Map").Paste

    With Sheets("Map").Shapes("BYD")
        .Left = 195
        .Top = 95

    End With


    Sheets("Wykresy").ChartObjects("GDA").Cut
    Sheets("Map").Paste

    With Sheets("Map").Shapes("GDA")
        .Left = 160
        .Top = 5

    End With


    Sheets("Wykresy").ChartObjects("GOW").Cut
    Sheets("Map").Paste

    With Sheets("Map").Shapes("GOW")
        .Left = 38
        .Top = 160

    End With


    Sheets("Wykresy").ChartObjects("KAT").Cut
    Sheets("Map").Paste

    With Sheets("Map").Shapes("KAT")
        .Left = 215
        .Top = 310

    End With

DoEvents 'lets the operating system clear / execute any backed up / queued events that it might have to execute.
'slow down the execution (to not get an error)
ThisWorkbook.Save
Application.CutCopyMode = False





    Sheets("Wykresy").ChartObjects("KIE").Cut
    Sheets("Map").Paste

    With Sheets("Map").Shapes("KIE")
        .Left = 300
        .Top = 280

    End With

    Sheets("Wykresy").ChartObjects("KRA").Cut
    Sheets("Map").Paste

    With Sheets("Map").Shapes("KRA")
        .Left = 265
        .Top = 350

    End With

    Sheets("Wykresy").ChartObjects("LDZ").Cut
    Sheets("Map").Paste

    With Sheets("Map").Shapes("LDZ")
        .Left = 230
        .Top = 210

    End With

    Sheets("Wykresy").ChartObjects("LUB").Cut
    Sheets("Map").Paste

    With Sheets("Map").Shapes("LUB")
        .Left = 410
        .Top = 230

    End With
    
    Sheets("Wykresy").ChartObjects("OLS").Cut
    Sheets("Map").Paste

    With Sheets("Map").Shapes("OLS")
        .Left = 275
        .Top = 40

    End With
    
DoEvents 'lets the operating system clear / execute any backed up / queued events that it might have to execute.
'slow down the execution (to not get an error)
ThisWorkbook.Save
    
Application.CutCopyMode = False
    

    Sheets("Wykresy").ChartObjects("OPO").Cut
    Sheets("Map").Paste

    With Sheets("Map").Shapes("OPO")
        .Left = 160
        .Top = 290

    End With


    Sheets("Wykresy").ChartObjects("POZ").Cut
    Sheets("Map").Paste

    With Sheets("Map").Shapes("POZ")
        .Left = 120
        .Top = 140

    End With


    Sheets("Wykresy").ChartObjects("RZE").Cut
    Sheets("Map").Paste

    With Sheets("Map").Shapes("RZE")
        .Left = 370
        .Top = 340

    End With


    Sheets("Wykresy").ChartObjects("SZC").Cut
    Sheets("Map").Paste

    With Sheets("Map").Shapes("SZC")
        .Left = 60
        .Top = 45

    End With


    Sheets("Wykresy").ChartObjects("WAW").Cut
    Sheets("Map").Paste

    With Sheets("Map").Shapes("WAW")
        .Left = 320
        .Top = 155

    End With



    Sheets("Wykresy").ChartObjects("WRO").Cut
    Sheets("Map").Paste

    With Sheets("Map").Shapes("WRO")
        .Left = 95
        .Top = 255

  Application.CutCopyMode = False

    End With

DoEvents 'lets the operating system clear / execute any backed up / queued events that it might have to execute.
'slow down the execution (to not get an error)
ThisWorkbook.Save

End Sub

Przykładowy plik tutaj.

Polecam również bardzo ciekawe artykuły tutaj: http://www.apocotenexcel.pl/mapa2.htm http://www.wiseowl.co.uk/blog/s130/excel-charts-data-labels-problem.htm https://support.microsoft.com/en-us/kb/914813

Superblog o C#, .net

Będę na pewno odwiedzać i polecać, notatnik i skarbnica wiedzy: http://patryknet.blogspot.com/ Podobne, na które natrafiłem przy okazji (związane z nauką C# i linq: http://coderpath.blogspot.com/2013/11/learn-and-practice-linq-c-with-linqpad.html http://www.filipekberg.se/2012/09/17/use-linqpad-for-more-than-linq/

Roll up, cube, group bardzo proste dzięki...

https://mndevnotes.wordpress.com/2012/10/03/grupowanie-danych-przy-uzyciu-polecen-rollup-cube-oraz-grouping-sets/

Ekwiwalenty MS SQL w Accesie

bez Over, Partition by? Odp. znalazlem tutaj: http://stackoverflow.com/questions/439138/running-total-by-grouped-records-in-table Kolejne, jak sobie poradzic bez INTERSECT... http://stackoverflow.com/questions/337158/how-can-i-implement-sql-intersect-and-minus-operations-in-ms-access

SQL w Excelu Cz.3: Odpowiednik MS SQL ROLLUP? Voila.

Mój eksperyment. TableA zawiera nieuporządkowaną ofertę po analizie cen. TableB zawiera opisy grup. Chcę uzyskać tabelę oferty z pogrupowanymi i podsumowanymi kodami (na podst. pierwszych trzech liter). Każda grupa powinna zaczynać się od wiersza z opisem grupy. :

SELECT  a as kod, b as wartosc, [Descr] as opis_grupy FROM TableA

UNION ALL SELECT  left(a,3)&"-Total" As kod, sum(b) As wartosc, "" as opis_grupy  FROM TableA

GROUP BY left(a,3)

UNION ALL SELECT a AS kod, "" AS wartosc, [Descr] AS opis_grupy FROM TableB

WHERE a IN (SELECT  left(TableA.a,3)FROM TableA)

UNION ALL SELECT  "-Grand Total-" As kod, sum(b) As wartosc, "" as opis_grupy  FROM TableA
ORDER BY kod;

Realizacja w VBA:

Public Sub SporzadzOferte()
Dim Myconnection As Connection
Dim Myrecordset As Recordset
Dim Myworkbook As String
Dim strSQL As String
Dim i As Integer

'Deal with input data range so that it refers to a Table and not to a Sheet!
'It will allow writing notes and puting a header above the table


Dim rngTableA As String

    rngTableA = Replace(Sheets("TableA").Range("TableA[#All]").Address, "$", "")
    rngTableA = "[TableA$" & rngTableA & "]"
 
'Debug.Print rngTableA


'--------------------

Set Myconnection = New Connection
Set Myrecordset = New Recordset
  
 
  
'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 12.0 Xml;HDR=YES;IMEX=1'"

'Build SQL Statement

    strSQL = "SELECT  a as kod, b as wartosc, [Descr] as opis_grupy FROM " & rngTableA & " " & _
"UNION ALL SELECT  left(a,3)&'-Total' As kod, sum(b) As wartosc, '' as opis_grupy FROM " & rngTableA & " " & _
"WHERE a IS NOT NULL " & _
"GROUP BY left(a,3)" & _
"UNION ALL SELECT a AS kod, '' AS wartosc, [Descr] AS opis_grupy FROM [TableB$]" & _
"WHERE a IN (SELECT  left(" & rngTableA & ".a,3) FROM " & rngTableA & ") " & _
"UNION ALL SELECT  'zzz-Grand Total-' As kod, sum(b) As wartosc, '' as opis_grupy  FROM " & rngTableA & " " & _
"ORDER BY kod"
 
    

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

    
'Place the Recordset onto SheetX
   With Sheets("Oferta")
    .Activate
    .ListObjects("Table3").DataBodyRange.Rows.Delete
    .Range("A5").CopyFromRecordset Myrecordset
    
 
    'Add column heading names
    For i = 1 To Myrecordset.Fields.Count
    .Cells(4, i).Value = Myrecordset.Fields(i - 1).Name
    Next i
   
   End With
   
   
   
   Set Myrecordset = Nothing
   Myconnection.Close
   
   Call BoldAndInsertEmptyRow
   
        
End Sub

Teraz jeszcze trzeba sformatować otrzymaną tabelę:

Option Explicit


Sub BoldAndInsertEmptyRow()

    Dim oListObj As ListObject
    Dim RowCnt As Long
    Dim r As Long

    Set oListObj = Worksheets("Oferta").ListObjects("Table3") 'change the sheet and table names accordingly
    
    Application.ScreenUpdating = False
   
' Solve the problem with values not showing up in proper (currency) format but in text format.
    Dim Cell As Range
    
    For Each Cell In oListObj.ListColumns("wartosc").DataBodyRange
    
           With Cell
               If .Value <> "" Then
                   .NumberFormat = "#,##0.00 $"
                   .Value = CCur(Val(.Value))
               End If
           End With
    
    Next Cell

   
    '==========
'Format rows with totals: add empty row above, frame, delete zzz grom Grand Total.
    
    RowCnt = oListObj.ListRows.Count
    
    For r = RowCnt To 1 Step -1
        With oListObj.ListRows(r).Range
            
            'If contains "TOTAL" - bold ent.row and add empty row below.
            
            If InStr(UCase((.Cells(1, 1).Value)), "TOTAL") > 0 Then
                .Font.Bold = True
                
                With .Borders(xlEdgeTop)
                    .LineStyle = xlContinuous
                    .ColorIndex = 0
                    .TintAndShade = 0
                    .Weight = xlMedium
                End With
                
                With .Borders(xlEdgeBottom)
                    .LineStyle = xlDouble
                    .ColorIndex = 0
                    .TintAndShade = 0
                    .Weight = xlThick
                End With

                If r < RowCnt Then
                    oListObj.ListRows.Add Position:=r + 1, alwaysinsert:=True
                End If
            End If
            
             ' format rows with description
            
            If .Cells(1, 2).Value = "" Then

                .Cells(1, 1).Font.Bold = True
                
                
                With .Borders(xlEdgeBottom)
                    .LineStyle = xlContinuous
                    .ColorIndex = 0
                    .TintAndShade = 0
                    .Weight = xlMedium
                End With
            
            End If
            
            'remve zzz from Grand Total
            
            If .Cells(1, 1).Value = "zzz-Grand Total-" Then
                    .Cells(1, 1).Value = "Grand Total"
            End If
            
        End With
    Next r


Application.ScreenUpdating = True

End Sub

Przykładowy plik tutaj.

Ciekawe strony na ten temat:
http://stackoverflow.com/questions/1839214/add-a-summary-row-to-ms-access-query
http://stackoverflow.com/questions/7157764/roll-up-and-cube-operator-in-access-summary-queries
https://technet.microsoft.com/en-us/library/bb510427(v=sql.105).aspx
http://p2p.wrox.com/access-vba/24326-roll-up-cube-compute-aggregate-funct-access.html

Również ciekawe, o subqueries:
http://allenbrowne.com/subquery-01.html
http://allenbrowne.com/subquery-02.html
http://stackoverflow.com/questions/11646664/querying-two-tables-in-ms-access?rq=1

Jak wygodnie edytować SQL...w VBA excela?

Może wyprowadzić treść łańcucha tekstowego na zewnątrz, by można go było edytować np. w Notepadzie++? Pogooglowałem.

Na przykład ciekawą propozycję znalazłem tutaj (autor Steve): http://stackoverflow.com/a/14916197/3480717
aby wczytywać string SQL z pliku tekstowego.

Quote:
// On initialization:
global strSQL
f = open("strSQL.sql")
strSQL = read_all(f)
close(f)

// To to the select:
DoCmd.RunSQL(strSQL)

... jak wciągnąć z pliku tekstowego do zmiennej string? Tutaj przykład: http://mrspreadsheets.com/1/post/2013/09/vba-code-snippet-22-read-entire-text-file-into-string-variable.html

A tutaj już bardzo użyteczny przykład: http://www.ozgrid.com/forum/showthread.php?t=173707

Jeśli plik tekstowy z kwerendą sql będzie już oddzielony od kodu VBA, będzie go można wygodnie edytować np. w Notepadzie++, korzystając z jego udogodnień jak np. kolorowanie składni. 
albo http://www.codeproject.com/Articles/37769/MS-Access-Databases-Queries-Editor

Lookup: Przypisz krótkie nazwy długim używając słownika.

W danych, które otrzymałem, występują nazwy firm w różnych wariantach. Mogę być pewien, że przynajmniej jeden człon, może jeden wyraz, będzie identyfikował poszczególne firmy. Tworzę więc słowniczek takich skróconych nazw, które występują w mojej bazie. Jak je przypisać?

1. Przetestowałem w Accesie:
Table_A to moja baza danych
Table_B to mój słowniczek skróconych nazw, które występują w długich nazwach.

SELECT Table_A.Full_name, Table_B.Short_name, Table_B.ID_firmy
FROM Table_B RIGHT JOIN Table_A ON  Table_A.Full_name Like "*"+Table_B.Short_name+"*";

2. Przetestowałem również w Excelu różne rozwiązania i ostatecznie otrzymałem podpowiedź na forum Altkom Pana Krzysztofa Rutkowskiego:

 

Słowniczek
Excomers	1
Futuro	2
Polexpo	3
Baza zewnętrzna	Tutaj działa formuła
Przedsiębiorstwo Handlu Polexpo.	3
Dystrybutor - FUTURO PUH	2
Excomers przedsiębiorstwo handlu	1
Przeds. Futuro Sp. z o.o.	2
Jan Kowalski Excomers.	1
polexpo	3
excomers	1

={INDEX($D$6:$D$8;MATCH(FALSE;ISERROR(SEARCH($C$6:$C$8;C12));0))}
Uwaga, formuła tablicowa Ctrl+Shift+Enter
Uwaga, słowniczek należy posortować malejąco.

gdzie C12 to nazwa długa w Bazie
zaś w słowniczku szukamy: $C$6:$C$8 to nazwa krótka, w zakresie $D$6:$D$8 - ID firmy,. Jeśli zaś do przyporządkowania nie ma zbyt wielu krótszych nazw, w Accesie można użyć switch'a a w MS SQLu IN.

SELECT 
 switch(
   Table1.Nazwa LIKE  "*Vicryl PLUS*", "Vicryl PLUS",
   Table1.Nazwa LIKE  "*Vicryl*" And  Table1.Nazwa Not LIKE "*PLUS*" , "Vicryl",
   Table1.Nazwa LIKE  "*Monocryl PLUS*", "Monocryl PLUS",
   true,"N/A"
   
 ),

Table1.Nazwa, Table1.Wartość
FROM Table1

Nauka LINQ bez SQL servera? Linq to Excel!

Polecam przykład użycia kwerendy napisanej w Linq przy użyciu biblioteki C# Linq to Excel (autor Paul Yoder): https://vimeo.com/7689508 Link zamieszczony w dyskusji Read Excel using LINQ (Stackoverflow).

Użycie razem bibliotek Linq to Excel i ExcelDNA może być niezmiernie przydatne np może służyć do. tworzenia makr, które na danych Excela będą wykonywać operacje bazodanowe.
Przykłady użycia Linq:http://codesamplez.com/database/linq-to-sql-c-sharp-tutorial https://code.msdn.microsoft.com/101-LINQ-Samples-3fb9811b

Syntax highlighter na stronach do wypróbowania.

Blogger może łatwo korzystać z kolorowania kodu. Opis tutaj, do wypróbowania w moim blogu wkrótce: http://stackoverflow.com/questions/10335463/how-to-setup-syntax-highlighter-on-blogger
(albo https://code.google.com/p/google-code-prettify/)

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.