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 SubTeraz 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 SubPrzykł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
Brak komentarzy:
Prześlij komentarz