<?xml version="1.0"?> <snippet language="OOBasic" application="Calc">
<keywords> <keyword>sort</keyword> <keyword>sorting</keyword> </keywords> <authors> <author id="swubuntu" initial="true" email="[EMAIL PROTECTED]">Stefan Weigel</author> </authors> <question heading="Improve sorting capabilities"> </question> <answer> <p>This macro provides an improved sorting function for the user.</p> <p></p> <p>It enables to sort using as many sort criteria as desired. (Calc normally allows max. 3 criteria.)</p> <p></p> <p>The sort criteria to be used is determined by the currently active cell. (Calc normally uses the first column.)</p> <p></p> <p>The macro recognizes if there are column headers (Calc normally does not recognize column header when using the sort icons from the toolbar)</p> <p></p> <p>The macro overcomes issue #7277 and issue #20491. For background info and long description see http://www.stefan-weigel.de/?ID=83. For German text see http://www.stefan-weigel.de/?ID=81</p> <listing>REM ***** BASIC ***** option explicit sub SWsortUp() thisComponent.lockcontrollers SWSort true thisComponent.unlockcontrollers end sub sub SWsortDown() thisComponent.lockcontrollers SWSort false thisComponent.unlockcontrollers end sub sub SWsort(blnUpDown) Dim oSheet ' the sheet that we are using Dim oListe as Object ' the cell range that is to be sorted Dim intListeStartSpalte ' number of the first column of the range that is to be sorted Dim intListeEndSpalte ' number of the last column of the range that is to be sorted Dim lngListeStartZeile ' number of the first row of the range that is to be sorted Dim lngListeEndZeile ' number of the last row of the range that is to be sorted Dim intListeAnzSpalten ' number of rows in the range that is to be sorted Dim lngListeAnzZeilen ' number of columns in the range that is to be sorted Dim intKritSpalte as Integer ' number of column that contains the sorting criteria Dim blnUeberschriften ' Does the list have column headers? Dim i as Integer ' iterator variable Dim oRange as Object ' another variable for a cell range Dim aSortFields(1) as New [EMAIL PROTECTED] com.sun.star.table.TableSortField} Dim aSortDesc(1) as New [EMAIL PROTECTED] com.sun.star.beans.PropertyValue} 'the sheet that we are using oSheet = ThisComponent.CurrentController.ActiveSheet 'the call range that was selected by the user oListe = thisComponent.CurrentSelection 'not more than one cell range is allowed if oListe.supportsService("[EMAIL PROTECTED] com.sun.star.sheet.SheetCellRanges}") then msgbox "Sortieren in mehreren Bereichen nicht möglich!",,"© Ingenieurbüro Weigel" exit sub end if 'find the column that contains the active cell oRange = thisComponent.createInstance("[EMAIL PROTECTED] com.sun.star.sheet.SheetCellRanges}") ThisComponent.CurrentController.Select(oRange) intKritSpalte = ThisComponent.CurrentSelection.getCellAddress.Column ThisComponent.CurrentController.Select(oListe) 'selection of list range in case one single cell has been selected '(trick: we use the automatic that Calc already has when sorting) SelectCurrentRange 'rows and colums of the range that is to be sorted intListeStartSpalte = ThisComponent.CurrentSelection.getRangeAddress.StartColumn intListeEndSpalte = ThisComponent.CurrentSelection.getRangeAddress.EndColumn intListeAnzSpalten = intListeEndSpalte - intListeStartSpalte lngListeStartZeile = ThisComponent.CurrentSelection.getRangeAddress.StartRow lngListeEndZeile = ThisComponent.CurrentSelection.getRangeAddress.EndRow lngListeAnzZeilen = lngListeEndZeile - lngListeStartZeile + 1 'number of the column that contains the sorting criteria intKritSpalte = intKritSpalte - intListeStartSpalte if lngListeAnzZeilen = 1 then exit sub 'are there column headers? blnUeberschriften = false 'the first row is considered to be a header row if the cells in the first and the second row contain different data types for i=intListeStartSpalte to intListeEndSpalte if oSheet.getCellByPosition(i,lngListeStartZeile).FormulaResultType <> oSheet.getCellByPosition(i,lngListeStartZeile+1).FormulaResultType and _ oSheet.getCellByPosition(i,lngListeStartZeile).FormulaResultType <> 0 and _ oSheet.getCellByPosition(i,lngListeStartZeile+1).FormulaResultType <> 0 then blnUeberschriften = true exit for end if next i if blnUeberschriften = false then 'the first row is also considered to be a header row 'if the cells in the first and the second row contain same data types but use different styles for i=intListeStartSpalte to intListeEndSpalte if oSheet.getCellByPosition(i,lngListeStartZeile).CellStyle <> oSheet.getCellByPosition(i,lngListeStartZeile+1).CellStyle then blnUeberschriften = true exit for end if next i end if 'insert a column for support oSheet.Columns.insertByIndex(intListeEndSpalte+1,1) 'list momentary order in support column for i=lngListeStartZeile to lngListeEndZeile oSheet.getCellByPosition(intListeEndSpalte+1,i).value=i next i oListe =oSheet.getCellRangeByPosition(intListeStartSpalte,lngListeStartZeile,intListeEndSpalte+1,lngListeEndZeile) 'do the sorting aSortFields(0).Field = intKritSpalte 'the column where the user has positioned the active cell aSortFields(0).IsAscending = blnUpDown aSortFields(0).IsCaseSensitive = false aSortFields(1).Field = intListeEndSpalte+1 'support column with momentary order aSortFields(1).IsAscending = true aSortFields(1).IsCaseSensitive = false aSortDesc(0).Name = "SortFields" aSortDesc(0).Value = aSortFields() aSortDesc(1).Name = "ContainsHeader" aSortDesc(1).Value = blnUeberschriften oListe.sort(aSortDesc()) 'remove the support column oSheet.Columns.removeByIndex(intListeEndSpalte+1,1) oListe =oSheet.getCellRangeByPosition(intListeStartSpalte,lngListeStartZeile,intListeEndSpalte,lngListeEndZeile) ThisComponent.CurrentController.Select(oListe) end sub sub SelectCurrentRange 'In order to select the current range we perform simple sorting and then undo it dim oDisp as object dim oDoc as object dim Array() oDoc = ThisComponent.CurrentController.Frame oDisp = createUnoService("[EMAIL PROTECTED] com.sun.star.frame.DispatchHelper}") oDisp.executeDispatch(oDoc, ".uno:SortAscending", "", 0, Array()) oDisp.executeDispatch(ThisComponent.CurrentController.Frame,".uno:Undo", "",0, Array()) End Sub </listing> </answer> <versions> <version number="2.1.0" status="tested"/> <version number="2.0.x" status="tested"/> </versions> <operating-systems> <operating-system name="All"/> </operating-systems> <changelog> <change author-id="swubuntu" date="2007-02-08">translated the comments to english</change> <change author-id="swubuntu" date="2007-01-25">Bug Fix</change> <change author-id="swubuntu" date="2006-10-22">Minor code improvements</change> </changelog> </snippet>
--------------------------------------------------------------------- To unsubscribe, e-mail: [EMAIL PROTECTED] For additional commands, e-mail: [EMAIL PROTECTED]
