Add a row below with copied formatting and (selective) data from the row above

Question

Hello everyone,

I'm trying to do something fairly complex (for me at least, may be not so complex for most of you):

Please have a look at the attached dummy spreadsheet image below.

As per attached spreadsheet you can use rows '3' to '14' as an example of how it's going to look like.

What I want to automate is; in case there are more items in the category I want to be able to press a button, a shortcut, or some kind of easy function that will automatically do the following:

Note: for purpose of easily explaining I will be assuming we are running the function whilst cell 'B15' is selected.

1. Create a new row below.
2. The new row ('16') will copy the formatting of the row above (Same borders and cell types)
3. Place zeros in columns 'E' and 'F' [Optional step]
4. Will copy the data/formula from the row above, in columns 'A', and 'G'.
5. The Subtotal formula (now in cell 'G17') will be updated to include the data in column 'G' of the new row ('G16')

I hope I sufficiently explained this. Hope someone can help me out here. I've been racking my brain for the last few days about this. And current forum post although some are useful, I don't have sufficient knowledge of excel to make use of it correctly.

If this is a bit hard/complex as a free community question, could someone please refer me to a service where they can do this for me (not free).

PS. Prefer to do this without use of macros, but if impossible than macros it is.

Many thanks

Answer 1

Be careful with the .Find command line. This forum likes to insert blank lines into code. There should be no blank lines in the 3line find command.

Option Explicit

Sub insert_item_row()

    Dim rw As Long, fnd As Range, addr As String

    rw = Selection.Cells(1).Row

    With ActiveSheet

        'check if this is an Item row

        If LCase(.Cells(rw, "D")) = "sub total" Then

            'selection is not an item row

            MsgBox "this sub procedure is not designed to create subtotal rows" & Chr(10) & "choose an item row", vbOKOnly + vbCritical, "bad choice"

            Exit Sub

        End If

        'copy, shift down, then insert

        .Range(.Cells(rw, "A"), .Cells(rw, "H")).Copy

        .Cells(rw + 1, "A").Insert Shift:=xlDown

        'clear some cell content

        Union(.Range(.Cells(rw + 1, "B"), .Cells(rw + 1, "D")), Cells(rw + 1, "H")).ClearContents

        'zero some cell values

        .Range(.Cells(rw + 1, "E"), .Cells(rw + 1, "F")) = 0

        'correct column A formula

        .Cells(rw, "A").Resize(2, 1).FillDown

        'repair all sections' subtotal row formula

        With .Range("D:D")

            'find first 'sub total'

            'temporaily disable error handling

            On Error Resume Next

            Set fnd = .Find(What:="sub total", after:=.Cells(1), LookIn:=xlFormulas, _

                            LookAt:=xlWhole, MatchCase:=False, SearchFormat:=False, _

                            SearchOrder:=xlByRows, SearchDirection:=xlNext)

            'restore error handling

            On Error GoTo 0

            'was one found?

            If Not fnd Is Nothing Then

                'save first found item address

                addr = fnd.Address(0, 0)

                'loop through all 'sub total' rows correcting formulas

                Do

                    'assign correct formula to column G

                    fnd.Offset(0, 3).FormulaR1C1 = "=sum(R[-1]C:index(R3C:R[-1]C, iferror(match(""zzz"", R3C[-3]:R[-1]C[-3])+1, 1)))"

                    'look for another

                    Set fnd = .FindNext(after:=fnd)

                'continue until it loops back to the first

                Loop Until addr = fnd.Address(0, 0)

            End If

        End With

    End With

End Sub

Answer 2

On a related note, what is the error message in G8 and G14? Does it go away with this formula in G8 (then copied to G14 and G16) while returning the correct subtotal(s)?

=SUM(G7:INDEX(G$3:G7, IFERROR(MATCH("zzz", D$3:D7)+1, 1)))

Answer 3

Hi Jeeped,

It's just an warning error of: "Inconsistent Formula", basically because above it's adding the adjacent cells in the above cells, meanwhile this one adds the cells above it.

The formula:

=SUM(G7:INDEX(G$3:G7, IFERROR(MATCH("zzz", D$3:D7)+1, 1))) 

Works the fine, but still has the same inconsistent formula error.

But please notice that cells: B3, C3, D3. are not merged

PS. Thanks for trying this out for me.

Best Regards.

Answer 4

DAMN!

Thank you so much Jeeped!

(PS. you were right this forum added an extra line between each and every line when pasting it into VBA)

Just one small problem, it doesn't actually change the subtotal formula. Unfortunately I am not sure why, this code is beyond me. 

It adds a line below the one selected and copies the column A content, column G formula, as well as puts zeros into columns E and F. But doesn't do anything to the sub-total.

Any ideas why that would be?

I would include the file, but don't know how to upload it onto here. And an image wouldn't give enough details

Many Thanks yous!

EDIT:

Just an FYI, in case it's important as to how I implemented the macro.

SO,

To add the macro I went alt+F11, then right click, insert>new Module

Copy + paste and deleted the spaces between the fnd command definition.

Then alt +F8 >Macro>Options>assign shortcut

Then pressed onto B7 and ran the macro. The line added, formulas on that line are all G.

But none of the Sub Total formulas changed.