The following macro joins all cells in the same column which are
next to each other and have the same value. For each joined area,
ehe macro continunes with subsequent columns as long as it stays
in the selection.
This first macro works on the current selection.
It calls the subroutine defined below for the actual merge process.
'========================================================================
'merge equal cells in selected area
Sub mergeEqualCellsInSelectedColumns
'get selected area
aDoc = StarDesktop.CurrentComponent
aSelection = aDoc.getCurrentSelection()
aArea = aSelection.getRangeAddress()
'merge the selected area in active document
mergeEqualCellsInColumns( aDoc, aArea )
End Sub
The following macro is the actual implementation of the merge process.
It could be used programmatically as it receives the document and selection to work on as arguments.
'merge equal cells in each column of the given area in the given document
Sub mergeEqualCellsInColumns( aDoc as object, aArea as com.sun.star.table.CellRangeAddress )
'get some commonly used objects
aSheet = aDoc.getSheets().getByIndex( aArea.Sheet )
'enumerate through all rows of the selection
for nRow = aArea.StartRow to aArea.EndRow
'only work on the first column yet
nCol = aArea.StartColumn
'get initial cell in row
aStartCell = aSheet.getCellByPosition( nCol, nRow )
aCursor = aSheet.createCursorByRange( aStartCell )
'find first cell with different content
nCompareRow = nRow+1
while ( nCompareRow <= aArea.EndRow and _
aSheet.getCellByPosition( nCol, nCompareRow ).getFormula() = aStartCell.getFormula() )
nCompareRow = nCompareRow + 1
wend
nLastEqualRow = nCompareRow-1
'are here equal cells at all?
if ( nLastEqualRow > nRow ) then
'merge range of all cells with identical content
aRange = aSheet.getCellRangeByPosition( nCol, nRow, nCol, nLastEqualRow )
aRange.merge(true)
aRange.VertJustify = 1
'if next column is still part of the subjected area
if nCol < aArea.EndColumn then
'specify the area in the next column within the merged rows
dim aSubArea as new com.sun.star.table.CellRangeAddress
aSubArea.Sheet = aArea.Sheet
aSubArea.StartRow = nRow
aSubArea.EndRow = nLastEqualRow
aSubArea.StartColumn = nCol+1
aSubArea.EndColumn = aArea.EndColumn
'recursively merge the cells in this area right of the merged area
mergeEqualCellsInColumns( aDoc, aSubArea )
endif
endif
'continue after merged area
nRow = nLastEqualRow
next
End Sub