Merge sheets of one spreadsheet document

Creating Extension - Shared Libraries
Forum rules
For sharing working examples of macros / scripts. These can be in any script language supported by [Basic, Python, Netbean] or as source code files in Java or C# even - but requires the actual source code listing. This forum is not for asking questions about writing your own macros.

Merge sheets of one spreadsheet document

Postby Villeroy » Thu Apr 05, 2018 4:23 pm

This macro is derived from Merge sheets of spreadsheet documents. That macro is embedded in a spreadsheet template. It reads spreadsheet files from a folder and merges the used areas of a specific sheet below a specified target cell within the document embedding the macro code.

Here is another variant that reads the used areas of selected sheets and writes the raw data below a specified target cell. Because it is supposed to work with any spreadsheet document (not just the embedding document), you save the code somewhere in your global container "My Macros" and perform the following steps:

1. Define a target sheet by specifying a cell named "Target". The name or position of the sheet does not matter. Just give the "Target" name to one of its cells.
How to: click the wanted cell and type the name into the name box left of the formula bar.
2. Optional: Define a named cell "Headers" where you enter the amount of header rows to be skipped. If you don't specify this cell, all rows will be merged.
3. Select all the sheets you want to be merged below the target cell. The sheet with the target cell won't be merged even if it is selected.
4. Call the Main routine of the below code.

The macro reads the used areas of all selected sheets skipping the target sheet if it is selected too, subtracts the specified amount of header rows and dumps the raw data (strings and values, no formulas nor formattings) below the current region of the target cell.
The data will be dumped with one column offset because the first column below the target cell gets the name of the source sheet so you won't lose any information.

Code: Select all   Expand viewCollapse view
REM  *****  BASIC  *****
Option Explicit

Const cCaller = "macro:SheetMerge.Main" 'error title
Const cMsg = "Please select one or more sheets other than the target sheet." 'error text
Const cTarget = "Target" 'cell name of target cell
Const cSkipRange = "Headers" 'cell name specifying the header rows count, default=0

Dim oCurrRegion, nSkip%

Sub Main()
'calls: getNamedCell, getCurrentRegion, getSheetIndices, processSheet
REM insert used ranges of selected sheets
REM into to the current region of the active cell
Dim oCell, oSel, addr
Dim a(), aI(), i%, xSheet%
Dim oSettings, bExpand As Boolean
   REM define target area as first row below current region
   REM around the cell named "Target"
   oSettings = createUnoService("")
   bExpand = oSettings.ExpandReferences
   oSettings.ExpandReferences = True
   oCell = getNamedCell(ThisComponent, cTarget)
   if ThisComponent.NamedRanges.hasByName(cSkipRange) then _
      nSkip = cInt(getNamedCell(ThisComponent, cSkipRange).getValue())
   oCurrRegion = getCurrentRegion(oCell)
   addr = oCurrRegion.getRangeAddress()
   xSheet = addr.Sheet
   REM define source areas
   oSel = ThisComponent.getCurrentSelection()
   if oSel.supportsService("") then
      if oSel.RangeAddress.Sheet = xSheet then
         MsgBox cMsg, 16, cCaller
         oSettings.ExpandReferences = bExpand
         exit sub
         a() = Array(oSel.getRangeAddress())
   elseif oSel.supportsService("") then
      a() = oSel.getRangeAddresses()
      MsgBox cMsg, 16, cCaller
      oSettings.ExpandReferences = bExpand
      exit sub
   aI() = getSheetIndices(a())
   for each i in aI()
      if i <> xSheet then
oSettings.ExpandReferences = bExpand
End Sub

Sub processSheet(oSheet)
'calls: getUsedRange, getRangeByAddress
Dim urg, src, rg, a(), x, y, adr, sh
   urg = getUsedRange(oSheet)
   src = urg.getRangeAddress()
   src.StartRow = src.StartRow + nSkip
   rg = getRangeByAddress(oSheet, src)
   if not isObject(rg) then exit sub
   a() = rg.getDataArray()
   x = uBound(a())
   y = uBound(a(0))
   adr = oCurrRegion.getRangeAddress()
   adr.EndColumn = adr.StartColumn + y +1
   adr.StartRow = adr.StartRow +1
   adr.StartRow = adr.EndRow +1
   adr.EndRow = adr.StartRow + x
   sh = oCurrRegion.getSpreadsheet()
   ' print rg.absolutename
   adr.StartColumn = adr.StartColumn +1
   rg = getRangeByAddress(sh, adr)
   adr.StartColumn = adr.StartColumn -1
   adr.EndColumn = adr.StartColumn
   rg = getRangeByAddress(sh, adr)
   oCurrRegion = getCurrentRegion(oCurrRegion)
end sub

Function getNamedCell(doc, s)
REM get named cell or top-left cell of a named range
Dim nx, obj
   nx = doc.NamedRanges
   obj = nx.getByName(s)
   getNamedCell = obj.getReferredCells.getCellByPosition(0,0)
End Function

'pass a spreadsheet-document, sheet or range  together with a c.s.s.table.CellRangeAddress
'return empty if oAddr out of bounds or wrong obj
Function getRangeByAddress(obj, oAddr as
on error goto nullErr:
Dim oSheet
   If obj.supportsService("") then
      REM use the sheet specified by given address
      oSheet = obj.getSheets.getByIndex(oAddr.Sheet)
      REM use given object (range/sheet) as parent range
      oSheet = obj
   getRangeByAddress = oSheet.getCellRangeByPosition(oAddr.StartColumn,oAddr.StartRow,oAddr.EndColumn,oAddr.EndRow)
exit function
   getRangeByAddress = Null
End Function

Function getUsedRange(oSheet)
Dim oCursor
   oCursor = oSheet.createCursor()
   getUsedRange = oCursor
End Function

Function getCurrentRegion(oRange)
Dim oCursor
   oCursor = oRange.getSpreadSheet.createCursorByRange(oRange)
   getCurrentRegion = oCursor
End Function

Function getSheetIndices(aAddr())
'calls bas_PushArray
REM get unique sheet indeces from array of range addresses
Dim a(), n%, x%, addr
   n = -1
   for each addr in aAddr()
      x = addr.Sheet
      if x > n then bas_PushArray(a(), x)
      n = x
   next addr
   getSheetIndices = a()
End Function

'_____________other generic function, not spreadsheet-specific____________________________________________
'very simple routine appending one single element to an array which may be undimensioned (LBound > UBound)
Sub bas_PushArray(xArray(),vNextElement)
Dim iUB%,iLB%
   iLB = lBound(xArray())
   iUB = uBound(xArray())
   If iLB > iUB then
      iUB = iLB
      redim xArray(iLB To iUB)
      iUB = iUB +1
      redim preserve xArray(iLB To iUB)
   xArray(iUB) = vNextElement
End Sub
Please, edit this topic's initial post and add "[Solved]" to the subject line if your problem has been solved.
Ubuntu 18.04, OpenOffice 4.x & LibreOffice 6.x
User avatar
Posts: 25976
Joined: Mon Oct 08, 2007 1:35 am
Location: Germany

Return to Code Snippets

Who is online

Users browsing this forum: No registered users and 1 guest