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.
Brak komentarzy:
Prześlij komentarz