Za trzy tygodnie, za trzy miesiące, mija termin... formatowanie warunkowe.

Może to proste ale nie wiedziałem, co wprowadzić jako formułę do formatowania warunkowego:

Za trzy miesiące:
=H5<=(EDATE(TODAY();3))

Za trzy tygodnie:
=H5<=(TODAY()+(7*3))

A co, jeśli data będzie powtarzać się cyklicznie? Np. co roku należy przeprowadzić kontrolę pojazdu etc.

Poniższa formuła podświetli wszystkie zbliżające się daty, na 3 tygodnie przed upłynięciem terminu.

=AND(TODAY()>=DATE(YEAR(TODAY());MONTH(K2);DAY(K2))-21;TODAY()<=DATE(YEAR(TODAY());MONTH(K2);DAY(K2)))

A gdy data jest w zakresie od dziś do trzech tygodni po terminie?

=AND(TODAY()<=DATE(YEAR(TODAY());MONTH(K2);DAY(K2))+21;TODAY()>DATE(YEAR(TODAY());MONTH(K2);DAY(K2)))

Edit: co jednak zrobić gdy kończy się rok a badana data jest na początku stycznia? Należałoby przyjąć, że  =IF(YEAR(TODAY()+21)=YEAR(TODAY())+1;YEAR(TODAY())+1;YEAR(TODAY()))

Po dodaniu powyższego obliczenia do formuły podświetlającej daty na 3 tygodnie przed upłynięciem terminu otrzymujemy takie monstrum (w Excelu można formułę podzielić na linie za pomocą Alt+Enter:

Czy 3 tygodnie i mniej przed terminem?


=AND(
TODAY()>=DATE(
(IF(YEAR(TODAY()+21)=YEAR(TODAY())+1;YEAR(TODAY())+1;YEAR(TODAY())));
MONTH(K2);DAY(K2))-21;
TODAY()<=DATE(
IF(YEAR(TODAY()+21)=YEAR(TODAY())+1;YEAR(TODAY())+1;YEAR(TODAY()));
MONTH(K2);DAY(K2)))

Czy do 3 tygodni po terminie?

=AND(TODAY()<=DATE(
IF(YEAR(TODAY()+21)=YEAR(TODAY())+1;YEAR(TODAY())+1;YEAR(TODAY()));
MONTH(K2);DAY(K2))+21;
TODAY()>DATE(
IF(YEAR(TODAY()+21)=YEAR(TODAY())+1;YEAR(TODAY())+1;YEAR(TODAY()));
MONTH(K2);DAY(K2)))

---

Co dalej (Edit 2015-06-06):
1. Chciałbym funkcję uprościć, zamienić na funkcję użytkownika (UDF) i umożliwić odhaczanie wykonanych napraw, np. przez porównanie do daty ostatnio wykonanej naprawy. Przy okazji nauczyłem się jak zwrócić #N/A :

Function ServiceDue(purchaseDate As Date, daysInAdv As Integer, _
Optional serviceDoneDate As Date) As Variant

    Application.Volatile
    
    Dim advDateBase As Date
    advDateBase = DateSerial(IIf(Year(Date) + daysInAdv = Year(Date) + 1, Year(Date) + 1, Year(Date)), _
    Month(purchaseDate), Day(purchaseDate))

If serviceDoneDate = Null Or Year(serviceDoneDate) <> Year(advDateBase) Then

    If Date > advDateBase - daysInAdv And Date <= advDateBase Then
        ServiceDue = advDateBase - Date
    ElseIf Date <= (advDateBase + daysInAdv) And Date > advDateBase Then
        ServiceDue = advDateBase - Date     'the same but I expect different action.
    Else
        ServiceDue = CVErr(xlErrNA)         'note how to return #NA
    End If
    
Else
    ServiceDue = CVErr(xlErrNA)
End If
    
    
End Function

2.Trzeba jeszcze posortować po kolorach. Jeszcze jeden problem. Ktoś doda kolumnę i makro przestaje działać albo sortowana jest niewłaściwa kolumna. Chciałbym odnosić się nie do zakresu ale do konkretnej kolumny, po nazwie. Czyli zamiast: .Add(Range("K1:K1") wolałbym bezpieczniej .Add(Range("1:1").Find(What:="Date of instalation/training", MatchCase:=False). Sortuję najpierw jeden potem drugi kolor tak by zaznaczone kolorem zielonym daty zbliżające się wystąpiły po datach dla których termin upłynął. W przypadku pierwszego koloru odnoszę się do nazwy kolumny, w przypadku drugiego do zakresu (dla porównania):

Private Sub Worksheet_Activate()

Dim lstobj As Object: Set lstobj = ActiveWorkbook.Worksheets("1").ListObjects("Table1")
    With lstobj.Sort
            .SortFields.Clear
            .SortFields.Add(Range("1:1").Find(What:="Date of instalation/training", MatchCase:=False), xlSortOnCellColor, xlAscending, , xlSortNormal) _
            .SortOnValue.Color = RGB(192, 0, 0)
            .SortFields.Add(Range("K1:K1"), xlSortOnCellColor, xlAscending, , xlSortNormal) _
            .SortOnValue.Color = RGB(0, 92, 42)
            .Header = xlYes
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
    End With
End Sub

O migracji z Excela do R

Na razie linkownia:
https://districtdatalabs.silvrback.com/intro-to-r-for-microsoft-excel-users
 https://chartsgraphs.wordpress.com/2011/01/09/learnr-toolkit-to-help-excel-users-move-up-to-r/ Książka: https://leanpub.com/r-for-excelusers
http://www.computerworld.com/article/2497464/business-intelligence-60-r-resources-to-improve-your-data-skills.html
http://www.rforexcelusers.com/

SQL w Excelu: Odpytaj plik tekstowy za pomocą funkcji Excela

Drobna przeróbka mojego poprzedniego makra w celu czytania i kwerendy plików tekstowych w Excelu za pomocą funkcji:

Function SQL(fileName As String, kolumny As String) As Variant
    Application.Volatile
    
 
    Dim path As String

    Dim cn As ADODB.Connection
    Dim rs As ADODB.Recordset
    Dim currAddress As String
    Dim varHdr, varDat, contentOut As Variant
    Dim nc, nr, i, j As Long
    
    path = ThisWorkbook.path & "\Data\"
    
    SQL = Null
    
    'currAddress = ActiveSheet.Name & "$" & dataRange.Address(False, False)
    
    strFile = ThisWorkbook.FullName
    strCon = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
               "Data Source=" & path & ";" & _
               "Extended Properties=""text; HDR=Yes; FMT=Delimited; IMEX=1;"""
    
    Set cn = CreateObject("ADODB.Connection")
    Set rs = CreateObject("ADODB.Recordset")
   
    rs.CursorLocation = adUseClient ' required to return the number of rows correctly
    cn.Open strCon
    
    strSQL = "select " & kolumny & " from " & fileName
    
    rs.Open strSQL, cn
    
    'Check if recordset is empty
    If rs.EOF Then
        MsgBox "Function does not return any values"
        SQL = ""
        Exit Function
    End If
    
    
    ' Process Column Headings
    nc = rs.Fields.Count
    ReDim varHdr(nc - 1, 0)
    For i = 0 To rs.Fields.Count - 1
        varHdr(i, 0) = rs.Fields(i).Name
    Next

    ' Get Rows from the Recordset
    nr = rs.RecordCount
    varDat = rs.GetRows

    ' Combing Header and Data and Transpose

    ReDim contentOut(0 To nr, 0 To nc - 1)
    For i = 0 To nc - 1
        contentOut(0, i) = varHdr(i, 0)
    Next

    
    
    
    For i = 1 To nr
        For j = 0 To nc - 1
           contentOut(i, j) = varDat(j, i - 1)
            
            
                
        Next
    Next

  ' Optional solution: Write Output Array to Sheet2
  '  With Sheet2
  '      .Cells.Clear
  '      .Range("A1").Resize(nr, nc) = contentOut
  '  End With
      
      
    'Figure out size of calling range which will receive the output array
    Dim nRow As Long: nRow = Application.Caller.Rows.Count
    Dim nCol As Long: nCol = Application.Caller.Columns.Count

    'Error if calling range too small
    If nRow < UBound(contentOut, 1) Or nCol < UBound(contentOut, 2) Then
        'Popup message
        'MsgBox "your range is too small."
        ' or return #VALUE! error
        SQL = "Too small range" 'CVErr(xlValue)
        ' or both or whatever else you want there to happen
        Exit Function
    End If

    'Initialise output array to match size of calling range
    Dim varOut As Variant
    ReDim varOut(1 To nRow, 1 To nCol)
    'And fill it with some background value
    Dim iRow As Long
    Dim iCol As Long
    For iRow = 1 To nRow
    
        For iCol = 1 To nCol
            varOut(iRow, iCol) = ""   ' or "funny bear", or whatever
        Next
    Next

    'Put content in output array and return
    For iRow = 0 To UBound(contentOut, 1)
        For iCol = 0 To UBound(contentOut, 2)
            varOut(iRow + 1, iCol + 1) = contentOut(iRow, iCol)
        Next
    Next
      
      
      
      SQL = varOut
    
    'Cleanup
    Erase contentOut
    Erase varHdr
    Erase varDat
    
    rs.Close
    Set rs = Nothing
    Set cn = Nothing


End Function

Ciekawe dodatki do Excela (MonteCarlo)

http://home.uchicago.edu/rmyerson/addins.htm

Dwa wykresy na jednym, "secondary axis".

Bardzo ciekawe pytanie na stronach Altkom: mamy serie danych w dwóch różnych tabelach. Na osiach x daty. Zakresy osi x pokrywają się, ale nie ich "rozdzielczość". Nie można danych z tabeli drugiej uśrednić, tak by pasowały do zakresów dat z tabeli 1, bo można utracić jakąś dynamiczną zmianę.

Tworzymy wykres. Dla serii z drugiej tabeli zaznaczamy, że chcemy skorzystać z "secondary axis", drugiej osi. Jeżeli któraś z serii danych jest opisana drugą "secondary" osią y to na wstążce narzędzi Tabela ukażą się opcje umożliwiające dodanie drugiej osi x, następnie można w zakresach danych źródłowych wskazać drugi zakres osi x.

Wskazówki znalazłem tutaj: http://stackoverflow.com/questions/22492786/excel-2013-horizontal-secondary-axis. Ciekawe, czy można sobie ułatwić tworzenie takich wykresów za pomocą vba, np. ciekawa dyskusja na ten temat na stronach: http://answers.microsoft.com/ 
oraz tutaj http://www.mrexcel.com/... a przede wszystkim tutaj http://stackoverflow.com/

Mój roboczy kawałek kodu:

Sub AddChart()


With ActiveSheet.Shapes.AddChart.Chart
    '.Name = "TestChart"
    .SetSourceData Source:=Range("'Sheet1'!$B$7:$E$14")
    .ChartType = xlColumnClustered
    .SeriesCollection(3).ChartType = xlLine
    .SeriesCollection(3).AxisGroup = xlSecondary
    .HasLegend = False

       ' add labels to Axes

       .Axes(1, xlPrimary).HasTitle = True
       '.Axes(1, xlPrimary).AxisTitle.Text = "Time S"

       .Axes(2, xlPrimary).HasTitle = True
       '.Axes(2, xlPrimary).AxisTitle.Text = "Current mA"
         
         .Axes(2, xlSecondary).HasTitle = True
       '.Axes(2, xlSecondary).AxisTitle.Text = "Temperature deg C"




End With





'
'     .HasAxis(xlCategory, xlPrimary) = True
'     .HasAxis(xlCategory, xlSecondary) = True
'     .HasAxis(xlValue, xlPrimary) = True
'     .HasAxis(xlValue, xlSecondary) = True
'     .Axes(xlCategory, xlPrimary).CategoryType = xlAutomatic
'     .Axes(xlCategory, xlSecondary).CategoryType = xlAutomatic
'  End With




End Sub

Plik dwa wykresy w jednym (na razie bez vba)

VBA jak znaleźć ostatni rząd i wkleić dane poniżej w przypadku obiektu tabela.

Polecam lekturę: http://www.reddit.com/r/excel/comments/2ky11l/vba_how_to_find_the_first_empty_row_in_a_sheet/ Ponadto, kilka rozwiązań znalazłem tutaj: http://blog.contextures.com/archives/2011/06/24/last-row-incorrect-with-excel-table/ i tutaj
http://www.reddit.com/r/excel/comments/2ky11l/vba_how_to_find_the_first_empty_row_in_a_sheet/
 1. Rozszerzenie zakresu tabeli.

   With Sheets("Oferta")
    
     lastrow = .Range("c65536").End(xlUp).Offset(1, 0).Row
     .ListObjects("Table3").Resize .Range("$A$6:$M$" & lastrow)

'następnie wklejam dane

     .Range("A" & lastrow).CopyFromRecordset Myrecordset
    
  
   End With

2. Użycie wyszukiwania pierwszej pustej komórki.

LastRowWithAnyDataInIt = Cells.Find(What:="*", SearchOrder:=xlRows, _
SearchDirection:=xlPrevious, LookIn:=xlValues).Row + 1

VBA Jeśli edytuję % rabatu, obliczana jest cena oferowana. Jeśli edytuję cenę oferowaną, zmienia się procent rabatu.

W formatce Excela edycja kolumny x powoduje wyliczenie w kolumnie y, a jeżeli zacznie edytować komórkę y, będzie wyliczona komórka x.
Jak zaspokoić taką potrzebę? Wstępnie zastanawiam się nad zastosowaniem VBA i on change.
- jeżeli edytowana jest komórka w kolumnie x, wstaw formułę w kolumnie y.
- jeżeli użytkownik edytuje komórkę w kolumnie y, wstaw formułę w kolumnie x.
Czy to dobry kierunek? Obawiam się trochę, że powstaną "circular references" - zapętlone formuły. Jak tego uniknąć?
Oczywiście sam nie pozostanę bezczynny i postaram się przez weekend poeeksperymentować ale bardzo byłbym wdzięczny za wszelkie odpowiedzi.

EDIT: Oto co osiągnąłem przez weekend:

Private oListObj As ListObject

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

Set oListObj = Worksheets("PROFORMA PLN").ListObjects("TableA")

Application.EnableEvents = True

    If Not Intersect(Target, oListObj.ListColumns("CENA OFEROWANA NETTO").DataBodyRange) Is Nothing Then
    Application.EnableEvents = False
    Target.Formula = Target.Value
    Application.EnableEvents = True
    End If
    
    If Not Intersect(Target, oListObj.ListColumns("OFEROWANY RABAT").DataBodyRange) Is Nothing Then
    Application.EnableEvents = False
    Target.Formula = Target.Value
    Application.EnableEvents = True
    End If



End Sub

Private Sub Worksheet_Change(ByVal Target As Range)

Set oListObj = Worksheets("PROFORMA PLN").ListObjects("TableA")

Application.EnableEvents = True

    If Not Intersect(Target, oListObj.ListColumns("CENA OFEROWANA NETTO").DataBodyRange) Is Nothing Then
    Application.EnableEvents = False
    Target.Offset(0, 6).Formula = "=IF([@[CENA OFEROWANA NETTO]]<>"""", -([@[CENA OFEROWANA NETTO]]-[@[CENA KATALOGOWA ZA 1 SZT]])/[@[CENA KATALOGOWA ZA 1 SZT]],"""")"
    Application.EnableEvents = True
    End If
    
    If Not Intersect(Target, oListObj.ListColumns("OFEROWANY RABAT").DataBodyRange) Is Nothing Then
    Application.EnableEvents = False
    Target.Offset(0, -6).Formula = "=IF([@[Descr]]<>"""",[@[CENA KATALOGOWA ZA 1 SZT]]-([@[CENA KATALOGOWA ZA 1 SZT]]*[@[OFEROWANY RABAT]]),"""")"
    Application.EnableEvents = True
    End If

End Sub

Makro działające w Excelu tutaj

Google: Python w Excelu

Polecam wypowiedź  na Quora: http://www.quora.com/What-are-the-benefits-of-Python-scripting-in-excel-versus-VBA

"Pytnon w excelu" ... wyszukiwanie zwróci m.in. takie wyniki:
http://xlwings.org/
https://datanitro.com/
Po pobieżnym przejrzeniu uważam, że stanowią dobrą alternatywę/dobre rozszerzenie  VBA.

Dodatkowo, ciekawe pytanie dot. data mining w Pytonie: http://www.quora.com/What-are-the-best-Python-2-7-modules-for-data-mining

Funkcja, która zamieni spacje na wiersze (excel)

Nie wiem, do czego mogłaby się przytać ale np. taka jak poniżej. Uwaga na użycie Join(Application.Transpose etc.

Wymyśliłem sobie zadanie: jak przerobić by funkcja wstawiała kolejny wiersz co ileś znaków lub co ileś wyrazów. cdn

Function SpacesToRows(myString As Range) As String
    SpacesToRows = Replace(Join(Application.Transpose(myString.Value), " "), " ", vbCrLf)
End Function

Zapytania MS SQL w VBA Excela - przejrzyście, elegancko.

Martin Dobie prezentuje przejrzyste rozwiązanie połączenia i wykonywania poleceń MS SQL z poziomu VBA Excela.
Jedna z funkcji przyjmuje jako argumenty parametry połączenia jak (nazwa_serwera, baza_danych). Inna obsługuje samo zapytanie, przyjmuje jako argument treść zapytania SQL). Kolejna rozłącza połączenie.
I ostatecznie, procedura, która wykorzystuje wszystkie te funkcje.

Polecam: http://www.mdobie.co.uk/2012/11/14/query-ms-sql-server-with-excel-vba/

Ponadto:
Connection string to MS SQL Localdb, polecam: https://sysmod.wordpress.com/2014/07/11/adodb-connection-string-for-localdb-and-sql-server-native-client/ 

Keyword: OPENROWSET Getting data from Excel into MSSQL: http://mikesknowledgebase.azurewebsites.net/pages/SQLServer/ImportExcelIntoSQLServer.htm
http://www.mssqltips.com/sqlservertip/1540/insert-update-or-delete-data-in-sql-server-from-excel/
http://www.mssqltips.com/sqlservertip/1202/export-data-from-sql-server-to-excel/ etc.

Excel VBA, podziel łańcuch na poszczególne znaki, liczbę na cyfry...

Na stronach stackoverflow znalazłem procedurę: http://stackoverflow.com/questions/13195583/split-string-into-array-of-characters Przerobiłem ją na funkcję UDF (czyli można jej używać jak funkcji tablicowej Excela, tj zaznaczyć więcej komórek, wpisać =SplitCell1(nasz_tekst), Ctrl+Shift+Enter i otrzymać w sąsiednich komórkach pojedyncze znaki/cyfry. Public Function splitCell1(str As String) As Variant

Dim buff As Variant

ReDim buff(Len(str) - 1)
For i = 1 To Len(str)
    buff(i - 1) = Mid$(str, i, 1)
Next
splitCell1 = buff

End Function

PS. Dodam tylko, jeśli są jakieś znaki oddzielające, to wystarczyłoby np:

Public Function SplitCell(rng As Range, delimit As String) As Variant
    SplitCell = (Split(rng, delimit))
End Function

Mała zabawa z powyższym (niestety zwraca do wszystkich komórek wart. tekstowe:

Public Function SplitCell(rng As String) As Variant
    Dim txtArray As Variant
       
    rng = Replace(rng, Chr(34) & " " & Chr(34), Chr(34) & Chr(34))
    txtArray = (Split(rng, Chr(34) & Chr(34)))
    txtArray(0) = DateValue(CDate(txtArray(0)))
    txtArray(3) = CCur(Replace(txtArray(3), ".", ","))
    txtArray(7) = Replace(txtArray(7), Chr(34), "")
    SplitCell = txtArray
End Function

Mean, Median, Modal, Skewness, Kurtosis - jak uzyskać w SQL, w Accesie i ACE SQL w VBA w Excelu?

Próbuję sobie jakoś radzić, np. znalazłem ciekawe info tutaj:
http://www.experts-exchange.com/Database/MS_Access/Q_28570259.html http://www.experts-exchange.com/articles/2529/Median-Mode-Skewness-and-Kurtosis-in-MS-Access.html 
Do doczytania i zapytania na forach (czy funkcje agregujące w VBA Accessa można użyć w ACE SQL w VBA Excela?)

Union, Resize ListObjectTable - Połączenie kilu zakresów komórek Tabeli (listobject Table)w VBA.

Np. w celu zmiany formatowania, patrz użycie Union:

'Thanks: https://quorum.akademiq.pl/discussion/comment/7324#Comment_7324

Dim oListObj As ListObject

Set oListObj = Worksheets("Oferta").ListObjects("Table3") 'change the sheet and table names accordingly

Dim k1 As Range
Dim k3 As Range
Dim k5 As Range
Dim kom As Range

Set k1 = oListObj.ListColumns("Cena netto").DataBodyRange
Set k3 = oListObj.ListColumns("Cena brutto").DataBodyRange
Set k5 = oListObj.("Tabela1").ListColumns("Wartość Netto").DataBodyRange

For Each kom In Union(k1, k3, k5)

 Debug.Print kom.Address

Next

End Sub

Jeżeli przylegają do siebie

  Dim cell As Range
    
    For Each cell In oListObj.ListColumns("Cena netto").DataBodyRange.Resize(, 4)

Autoincrement - pole automatycznie zliczające.

Jak to zrobić w Accesie/ACE SQL? Nie wiem... W Excelu odpowiedź znalazłem np. tutaj: http://www.4gaccounts.com/5-ways-to-increment-the-cell-values-in-excel/ 

Funkcja
=IF (B3=””,””, COUNTA ($A$2:A2) +1-COUNTBLANK ($A$2:A2)) albo =IF(B3=””,””,COUNTA($B$3:B3)) albo
=IF(C4=”name”, COUNTA($B$2:B3)+1-COUNTBLANK($B$2:B3),””) etc...

Co jednak, gdy kolumnę zliczającą chcę mieć w Excelu w tabeli, której wszystkie rzędy podczas uaktualniania z zapytania ACE SQL są za każdym razem usuwane przez VBA?

Jeśli jest to tabela (ListObject Table), okazuje się, że wystarczy wkleić makrem formułę do pierwszej komórki kolumny L.p. a reszta komórek w kolumnie zostanie automatycznie wypełniona formułą:

'Add autoincrement to first column
Worksheets("Oferta").Range("A7").Formula = "=IF(B7="""","""",COUNTA($B$7:B7))" 

Może to nie jest najlepsze rozwiązanie, ale działa. Muszę poczytać więcej o: - podzapytaniach, które pozwoliłyby na wykonanie autonumeracji w SQL, - odnoszeniach się do elementów tabeli raczej (ListObject table) niż do adresów komórek. Re1: do przeczytania: ACC2000: How to Rank Records Within a Query https://support.microsoft.com/pl-pl/kb/208946 do przestudiowania, przykład od Pana Jacka Zajadacza, autonumerowanie grup, tutaj płci:

SELECT p1.ID, p1.[Nazwisko], p1.[Imie], p1.plec, count(*) as NUMER
FROM Pracownicy AS p1 INNER JOIN Pracownicy AS p2 
ON p1.ID > p2.ID and p1.plec= p2.plec
GROUP BY p1.ID, p1.[Nazwisko], p1.[Imie], p1.plec
ORDER BY p1.plec

Re2: np.

'thanks http://stackoverflow.com/questions/18811431/refer-to-excel-cell-in-table-by-header-name-and-row-number-vba
Worksheets("Oferta").ListObjects("Table3").DataBodyRange.Cells(1, ActiveSheet.ListObjects("Table3").ListColumns("Lp").Index).Formula = "=IF(B7="""","""",COUNTA($B$7:B7))"

'or more readable

Dim tb As ListObject
'assumes Table is the first one on the ActiveSheet
Set tb = Worksheets("Oferta").ListObjects("Table3") ' or less precisely ActiveSheet.ListObjects(1)
    tb.DataBodyRange.Cells(1, tb.ListColumns("Lp").Index.Formula = "=IF(B7="""","""",COUNTA($B$7:B7))"

EDIT:

Ostatecznie pojawiła się nowa potrzeba:  Muszę policzyć tak, by licznik resetował się, zaczynał od nowa,  gdy rozpocznie się nowa grupa:


=IF(G2<>"";COUNTIF($G$2:G2;G2);"")

SQL w Excelu Cz.4: Odpowiednik MS SQL ROLLUP'a ciąg dalszy.

W poprzednim poście sumowałem grupy produktów, w których zgadzały się pierwsze trzy litery kodu. Teraz inne zadanie - mam pogrupować grupy produktów na podstawie wyrażeń występujących w ich nazwach. Przy czym w osobnej grupie ma się znaleźć produkt xyz a w osobnej xyz pro. Nie mogą zsumować się w jednej grupie produkty xyz i xyz pro!. Poniżej kod i pliki przykładowe.

Przetestowane w MS Access query (kluczowe jest tutaj użycie
- w SELECT:  max(TableB.Descr)
- połączenia ON  TableA.Descr LIKE (TableB.Descr+"*")

SELECT opis, wartosc
FROM (SELECT DISTINCT "0" as col_order,  opisszczegolowy as opis, ""  as wartosc, majorID FROM
  (SELECT  TableA.descr as opis, max(TableB.Descr) AS major, b, first(TableB.ID) as majorID, first(TableB.Details) as opisszczegolowy
   FROM TableB 
   RIGHT JOIN TableA 
   ON  TableA.Descr LIKE (TableB.Descr+"*") 
   GROUP BY  TableA.descr,b )

UNION ALL

SELECT  "1" as col_order,  opis, b as wartosc, majorID FROM
  (SELECT  TableA.descr as opis, max(TableB.Descr) AS major, b, first(TableB.ID) as majorID
   FROM TableB 
   RIGHT JOIN TableA 
   ON  TableA.Descr LIKE (TableB.Descr+"*") 
   GROUP BY  TableA.descr,b )

UNION ALL

SELECT   "2" as col_order, major+" Total" as opis, sum(b) as wartosc, first(majorID) FROM
  (SELECT  TableA.descr as opis, max(TableB.Descr) AS major, b, first(TableB.ID) as majorID
   FROM TableB 
   RIGHT JOIN TableA 
   ON  TableA.Descr LIKE (TableB.Descr+"*") 
   GROUP BY  TableA.descr,b )
GROUP BY major

UNION ALL

SELECT   "3" as col_order, "Grand Total" as opis, sum(b) as wartosc, "999999" as majorID FROM TableA

)  AS [Rollup_Result]
ORDER BY majorID, col_order;

A teraz trzeba rozwiązanie przekształcić na string SQL ACE OLEDB. W pierwszym kroku użyłem do tego celu narzędzia SQLinFormpro do formatowania łańcuchów SQL w VB (do 100 linii za darmo). Bardzo pomocne narzędzie, dzięki sensownym wcięciom pomogło mi odnaleźć się w gąszczu kodu:

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'"

 
strSQL = "" & _
"SELECT   opis, wartosc " & _
"FROM     (SELECT DISTINCT '0'               AS col_order," & _
"                          [opisszczegolowy] AS [opis],       " & _
"                          ''                AS [wartosc]," & _
"                          majorID  " & _
"         FROM    (SELECT    " & rngTableA & ".descr      AS opis  ,  " & _
"                            MAX([TableB$].Descr)         AS [major] ,  " & _
"                            b                          ,  " & _
"                            first([TableB$].ID)          AS [majorID],  " & _
"                            first([TableB$].[Details])   AS opisszczegolowy " & _
"                 FROM       [TableB$] " & _
"                            RIGHT JOIN " & rngTableA & " " & _
"                            ON         " & rngTableA & ".Descr LIKE ([TableB$].Descr+'%') " & _
"                 GROUP BY   " & rngTableA & ".descr, b) " & _
"    UNION ALL "

strSQL = strSQL + "           " & _
"          SELECT '1' AS col_order,  " & _
"                 opis          ,  " & _
"                 b AS wartosc  ,  " & _
"                 majorID  " & _
"          FROM   (SELECT    " & rngTableA & ".descr      AS opis ,  " & _
"                            MAX([TableB$].Descr)         AS major,  " & _
"                            b                         ,  " & _
"                            first([TableB$].ID)          AS majorID " & _
"                 FROM       [TableB$] " & _
"                            RIGHT JOIN " & rngTableA & " " & _
"                            ON         " & rngTableA & ".Descr LIKE ([TableB$].Descr+'%') " & _
"                 GROUP BY   " & rngTableA & ".descr,  b) " & _
"    UNION ALL "

strSQL = strSQL + "           " & _
"          SELECT   '2'            AS col_order,  " & _
"                   major+' Total' AS opis     ,  " & _
"                   SUM(b)         AS wartosc  ,  " & _
"                   first(majorID)  " & _
"          FROM     (SELECT    " & rngTableA & ".descr      AS opis ,  " & _
"                              MAX([TableB$].Descr)         AS major,  " & _
"                              b                         ,  " & _
"                              first([TableB$].ID)          AS majorID " & _
"                   FROM       [TableB$] " & _
"                              RIGHT JOIN " & rngTableA & " " & _
"                              ON         " & rngTableA & ".Descr LIKE ([TableB$].Descr+'%') " & _
"                   GROUP BY   " & rngTableA & ".descr, b  ) " & _
"          GROUP BY major " & _
"    UNION ALL "

strSQL = strSQL + "           " & _
"          SELECT '3'            AS col_order,  " & _
"                 'Grand Total'  AS opis     ,  " & _
"                 SUM(b)         AS wartosc  ,  " & _
"                 '999'          AS majorID  " & _
"          FROM   " & rngTableA & " " & _
"         )  " & _
"ORDER BY [majorID], [col_order]"

'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 

Uwaga, podczas edycji otrzymałem komunikat, że string SQL był za długi, więc musiałem go podzielić na kilka stringów. Dzięki temu łańcuch SQL stał się jeszcze bardziej czytelny, pojawiło się miejsce na komentarze między łączonymi tabelami.
Pozostało formatowanie. Uwaga, odkryłem, że funkcja val nie jest dobra do konwersji liczb w postaci tekstowej do liczb w formacie currency, powoduje utratę miejsc po przecinku, w jej miejsce zastosowałem CDbl

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 = CDbl(.Value)  'not CCur(Val(.Value)) because you are loosing fractions.
               End If
           End With
    
    Next Cell

   
    '==========
'Format rows with totals: add empty row above, frame.
    
    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
            
          
        End With
    Next r


Application.ScreenUpdating = True

End Sub

Pliki przykładowe: test zapytania SQL w MSAccesie działająca formatka z zapytaniem ACE SQL w Excelu.

Bletchley Park's Lost Heroes - zapomnieni superbohaterowie epoki IT.

Tommy Flowers i Bill Tutte.  Skrócili wojnę o kilka lat, wygrali bitwy, uratowali miliony ludzi, położyli podwaliny pod dzisiejszy postęp w dziedzinie IT. Po wojnie nałożono na nich obowiązek milczenia aż po grób, stworzono alternatywną narrację, przykryto innymi nazwiskami... . Inni zebrali laury, nagrody, na cześć innych nakręcono pochwalne bardzo nieprawdziwe filmy dotyczące sukcesów kryptograficznych Bletchley Park,budowy pierwszego elektronicznego komputera.  Zostali skazani na zapomnienie, jak nasi matematycy, którzy złamali Enigmę. Historia przypomina mi losy bohaterów dywizjonu 303.


Linki:
Obejrzałem w TV: https://www.youtube.com/watch?v=bMu8UiHJHgs
Tommy Flowers http://en.m.wikipedia.org/wiki/Tommy_Flowers
Bill Tutte http://en.m.wikipedia.org/wiki/W._T._Tutte
Inni liczni bohaterowie (również dźwięk generowany przez teleprinter/maszynę szyfrującą (RTTY): https://www.youtube.com/watch?v=b4WBINgRMTY 
Co dziś usłyszymy w muzeum: https://www.youtube.com/watch?v=GBsfWSQVtYA

Ciekawy blog nt. zaawansowanych wykresów w Excelu..

1. Heat maps
Wykorzystanie formatowania warunkowego do tworzenia "heat maps". Może być przydatne do identyfikowania klastrów. http://excelgraphs.blogspot.com/2013/03/heat-map-plot-in-excel-using.html

A oto moja wersja (na G_Drive):
- Za pomocą SUMPRODUCT zliczam ilość wystąpień dla poszczególnych zakresów cen i rabatów.
- Za pomocą prostego makra kopiuję z osi wykresu zakresy cen i rabatów dla klikniętej komórki wykresu i wstawiam do formuły wyszukującej rekordy, których dotyczy kliknięta komórka.

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

Dim CheckRange As Range
Dim r As Integer
Dim c As Integer

'Set the plot's range
    Set CheckRange = Range(Cells(5, 6), Cells(16, 13))

'If I click in the plot's range
    If Not Intersect(Target, CheckRange) Is Nothing Then

'Detect row and column where I clicked

With ActiveCell
r = .Row
c = .Column
End With

'Copy from respective axis to cells with search conditions.

'min
Cells(21, 8).Value = Cells(r + 1, 5).Value
'max
Cells(22, 8).Value = Cells(r, 5).Value
'disc min
Cells(23, 8).Value = Cells(17, c - 1).Value
'disc max
Cells(24, 8).Value = Cells(17, c).Value

End If
End Sub

- Jako uzupełnienie polecam stronę http://fiveminutelessons.com/learn-microsoft-excel/use-index-lookup-multiple-values-list opisującą formułę, która pozwala wyszukać kilka recordów spełniających określone kryteria.

2. "rysowanie drzew" :-) z wykorzystaniem pakietu stat. R i dodatku RExcel http://excelgraphs.blogspot.com/2013/04/plotting-dendogram-of-cluster-analysis.html
Scatterplot matrix: http://excelgraphs.blogspot.com/2013/04/scatter-plot-matrix-in-excel-using.html

Opis instalacji RExcel dla opornych: http://excelgraphs.blogspot.com/2013/04/extend-your-excel-graphics-capabilities.html

Budowanie łańcucha SQL w VBA, ciekawe rozwiązania.

Niezwykle użyteczne narzędzie do formatowania łańcucha SQL do użycia w kodzie VBA. http://www.sqlinform.com/. Poprawia czytelność kodu i wyświetla komunikaty o błędach w poszczególnych liniach. Do 100 linii za darmo. Polecam również ciekawy przykład budowania łańcucha zapytania SQL w VBA, w tym przypadku obsługującego formularze. http://www.baldyweb.com/BuildSQL2.htm EDIT: Uwaga, w VBA zamiast "*" wildcard'u używa się "%". Straciłem dużo czasu zastanawiając się dlaczego pewne query działa w Accesie a nie w SQL. Na StackOverflow znalazłem odpowiedź.