Ask Your Question
0

Calc - Copy merged cells when adding new rows

asked 2016-08-27 17:43:28 +0100

miketurn gravatar image

updated 2016-08-27 17:44:03 +0100

Hello Everyone,

Lets say you have a spreadsheet.

Rows 1-10 each have Columns A, B and C merged together.

Now say you want to add a new row between Row 4 and 5.

When you select Row 5 it highlights the Row 5 going from Column A, B and C.

Now when you use your trusty "Insert Rows Above" tool it creates a new row.

Problem is this new row no longer has Columns A, B and C merged together.

Does anyone know of any settings that could allow Calc to copy the merged properties of the cells selected when inserting new rows between them?

Thank You

edit retag flag offensive close merge delete

2 Answers

Sort by » oldest newest most voted
0

answered 2016-08-28 07:12:54 +0100

pierre-yves samyn gravatar image

Hi

May be a workaround: we can get the desired result by the Paste SpecialSelection: FormatsShift Cells:Down (must already have copied the line first of course)

Regards

edit flag offensive delete link more
0

answered 2016-08-28 20:22:54 +0100

mark_t gravatar image

updated 2016-08-29 08:20:07 +0100

pierre-yves samyn gravatar image

The insert range and copy paste special can be automated using the following macro. This could be assigned to a hot key.

Select the range to insert, run InsertFormatRange, this will insert the range and copy paste formats and cell merge from the top row of your original selection.

REM  *****  BASIC  *****

Option Explicit

Sub InsertFormatRange

    Dim oCurSelection As Object

    oCurSelection = thisComponent.CurrentSelection

    oCurSelection.Spreadsheet.insertCells(oCurSelection.RangeAddress, com.sun.star.sheet.CellInsertMode.DOWN)

    FormatRange
End Sub

Sub FormatRange
'   Format selected Range to match the row above the selection '

    Dim oCurSelection As Object
    Dim oController As Object
    Dim oSelRangeAddress As New com.sun.star.table.CellRangeAddress
    Dim oRefRangeAddress As New com.sun.star.table.CellRangeAddress
    Dim sSelAbsoluteName As String
    Dim sRefAbsoluteName As String

    oCurSelection = thisComponent.CurrentSelection
    sSelAbsoluteName = oCurSelection.AbsoluteName
    oSelRangeAddress = oCurSelection.RangeAddress

    If oSelRangeAddress.StartRow < 1 Then
        msgbox  "There is no row above the selection to copy formats."
        Exit Sub
    End If

    oRefRangeAddress = oSelRangeAddress
    oRefRangeAddress.StartRow = oSelRangeAddress.StartRow - 1
    oRefRangeAddress.EndRow = oSelRangeAddress.StartRow - 1

    sRefAbsoluteName = CellAddressString(oRefRangeAddress)

    '   Now use dispatch to copy and paste special '

    rem ----------------------------------------------------------------------
    rem define variables
    dim document   as object
    dim dispatcher as object
    rem ----------------------------------------------------------------------
    rem get access to the document
    document   = ThisComponent.CurrentController.Frame
    dispatcher = createUnoService("com.sun.star.frame.DispatchHelper")

    rem ----------------------------------------------------------------------
    dim args1(0) as new com.sun.star.beans.PropertyValue
    args1(0).Name = "ToPoint"
    args1(0).Value = sRefAbsoluteName

    dispatcher.executeDispatch(document, ".uno:GoToCell", "", 0, args1())

    rem ----------------------------------------------------------------------
    dispatcher.executeDispatch(document, ".uno:Copy", "", 0, Array())

    rem ----------------------------------------------------------------------
    dim args3(0) as new com.sun.star.beans.PropertyValue
    args3(0).Name = "ToPoint"
    args3(0).Value = sSelAbsoluteName

    dispatcher.executeDispatch(document, ".uno:GoToCell", "", 0, args3())

    rem ----------------------------------------------------------------------
    dim args4(5) as new com.sun.star.beans.PropertyValue
    args4(0).Name = "Flags"
    args4(0).Value = "T"
    args4(1).Name = "FormulaCommand"
    args4(1).Value = 0
    args4(2).Name = "SkipEmptyCells"
    args4(2).Value = false
    args4(3).Name = "Transpose"
    args4(3).Value = false
    args4(4).Name = "AsLink"
    args4(4).Value = false
    args4(5).Name = "MoveMode"
    args4(5).Value = 6

    dispatcher.executeDispatch(document, ".uno:InsertContents", "", 0, args4())
End Sub

Function CellAddressString(oCellAddr as Object) as String

    Dim FuncService As Object

    '   Create service to access sheet functions '
    FuncService = createunoservice("com.sun.star.sheet.FunctionAccess")

    CellAddressString = FuncService.CallFunction("ADDRESS", _
                                            array(oCellAddr.StartRow+1, _
                                            oCellAddr.StartColumn+1))

    If oCellAddr.EndRow > oCellAddr.StartRow Or oCellAddr.EndColumn > oCellAddr.StartColumn Then
        CellAddressString = CellAddressString _
                            & ":" & FuncService.CallFunction("ADDRESS", _
                            array(oCellAddr.EndRow+1, oCellAddr.EndColumn+1))
    End If                                  
End Function
edit flag offensive delete link more

Comments

My edit is only to add ' at the end of comment line (no need in LibO Basic but here yes....)

pierre-yves samyn gravatar imagepierre-yves samyn ( 2016-08-29 08:19:52 +0100 )edit

Thanks, it does improve format, I'll try to remember to include in future.

mark_t gravatar imagemark_t ( 2016-08-29 14:40:18 +0100 )edit
Login/Signup to Answer

Question Tools

1 follower

Stats

Asked: 2016-08-27 17:43:28 +0100

Seen: 184 times

Last updated: Aug 29 '16