Macro to insert new row and copy a value overwrites the row below

Question

I have written a macro that searches a column for a cell that contains the text "AddCompany" and then for each such cell, inserts a new row into a different sheet and then copies and pastes the value of the adjacent cell (which contains the name of a company) into that new row.

In my copy, I am using made up names in the cells, "Test Company 1" thru "Test Company 4", to test the macro. The macro correctly inserts 4 new rows but only the last company, "Test Company 4" gets pasted. And it gets pasted into the wrong cell, in the row directly below the newly inserted rows.

The final result is that the macro inserts rows 9 thru 12, and pastes "Test Company 4" into row 13 which already contains a name (that I do not wish to change).

What I want the macro to do is to insert a "new" row (just happens to be the 9th row in this case to fit in a larger table) for each "AddCompany" it finds, then paste the company name in the adjacent cell, and repeat until done. The newly inserted rows 9 thru 12 should display each test company in the end.

Any help will be much appreciated.

Thanks, Jon

Sub AddMoreCompanies()

Dim Table As Worksheet:     Set Table = Worksheets(1)
Dim Notes As Worksheet:     Set Notes = Worksheets(2)
Dim Accounts As Worksheet:  Set Accounts = Worksheets(3)
Dim SandI As Worksheet:     Set SandI = Worksheets(4)
Dim Report As Worksheet:    Set Report = Worksheets(5)
Dim Entry As Worksheet:     Set Entry = Worksheets(6)
Dim Issuer As Worksheet:    Set Issuer = Worksheets(7)

Dim Col As Range:           Set Col = Entry.Range("L5:L250")
Dim tCell As Range
Dim Target As Range:        Set Target = Table.Range("D9")

For Each tCell In Col
    If tCell.Value = "AddCompany" Then
            'Inserts new row in the Table
            Table.Rows("9:9").Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
            Table.Rows("10:10").Copy
            Table.Rows("9:9").PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
                SkipBlanks:=False, Transpose:=False
            Application.CutCopyMode = False
            Table.Range("E10:I10").AutoFill Destination:=Range("E9:I10"), Type:=xlFillDefault
            'copies text into target cell
            Else
        End If
    If tCell.Value = "AddCompany" Then
        Target.Value = tCell.Offset(0, 1).Value
        Else
    End If
    Next tCell
    'Target.Value = tCell.Offset(0, 1).Value  
End Sub

Have you tried inserting the copied row, rather than pasting? You can insert multiple times to the row above the activerow, if need be. — Cyril
Hi Cyril, the intention was not to copy a whole row, but rather insert a new row, copy formatting and some formulas (that part works fine.) My problem comes with copying a value from one of the cells adjacent to the cell containing "AddCompany" and pasting that value into cell D9. A.H.S just provided me an answer that works for this particular macro, but I am interested in hearing what you mean by your comment. its likely a misunderstanding of your question on my part but I don't quite understand what it is you're suggesting. Thanks — Jon0311
I was thinking that you would copy the row containing the "add company" text, then insert it 3 times to the row BELOW the activerow. You can then .formula="" Test Company 1 - 4 into each of those 4 (total 4... original + 3) rows, fully replacing the "add company" cell, so it wouldn't be picked up if the loop were to be run again. Luckily ASH was able to provide a fix for the issue, so regardless of my comment making sense, you've at least got that ~_* — Cyril

A.S.H A.S.H · Accepted Answer · 2017-07-18T19:19:39

What you are missing is that the Target variable, defined as Set Target = Table.Range("D9") will move down and become D10, then D11 (till D13) each time you Insert a new row above it.

For a quick-fix, try to redefine it before copying the value. By changing

Target.Value = tCell.Offset(0, 1).Value

into

Table.Range("D9").Value = tCell.Offset(0, 1).Value

Macro to insert new row and copy a value overwrites the row below

1 Answers