Conditionally Copy from Row Above Following Add Row VBA

[LBinGA]

Hi all:

I have this bit of code for adding a Row alphabetically into a Contacts sheet. Works great.

Sub InsertCompany()Dim sNewName As String
Dim lPosition As Long
Dim rEmpList As Range


Set rEmpList = Range("D1:D1000")


sNewName = InputBox("Enter Name of Company for added Contact")
On Error Resume Next 'if employee needs to go at start of list, Match will return [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=NA]#NA[/URL] 
lPosition = Application.WorksheetFunction.Match(sNewName, rEmpList, 1)
On Error GoTo 0 'revert to normal error handling (crashing)
rEmpList(lPosition + 1).Insert
rEmpList(lPosition + 1).Value = sNewName
rEmpList(lPosition + 1).Activate


End Sub

I would like the code to look at the Company Name just added and look one cell above to determine if it matches. If it does, it should copy the data in the cells above to the blank cells just added. If not, do nothing more.

For instance, if D2 was just added via the above code, it should look at D1, determine if it's an exact match and if so copy, say, Range F1:G1 to F2:G2. (I'll set up the exact Range.)

	Column D	Column E	Column F	Column G
Row 1	Joe Smith	2	3	4
Row 2	Joe Smith		3	4
Row 3	Jane Doe	6	7	8
Row 4	Scooby Doo	10	11	12

<tbody>
</tbody>

Thanks,

LBinGA

 

[cooper645]

LBinGA,

Here is the code you need.

Sub InsertCompany()Dim sNewName As String
Dim lPosition As Long
Dim rEmpList As Range




Set rEmpList = Range("D1:D1000")




sNewName = InputBox("Enter Name of Company for added Contact")
On Error Resume Next 'if employee needs to go at start of list, Match will return [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=NA]#NA[/URL] 
lPosition = Application.WorksheetFunction.Match(sNewName, rEmpList, 1)
On Error GoTo 0 'revert to normal error handling (crashing)
rEmpList(lPosition + 1).EntireRow.Insert
rEmpList(lPosition + 1).Value = sNewName
rEmpList(lPosition + 1).Activate


If [COLOR=#ff0000]ActiveCell.Offset(-1, 0).Value = ActiveCell.Value[/COLOR] Then
    [COLOR=#0000cd]Range(ActiveCell.Offset(-1, 1), ActiveCell.Offset(-1, 3)).Copy[/COLOR] [COLOR=#ffa500]ActiveCell.Offset(0, 1)[/COLOR]
End If


End Sub

​If the cell 1 row above has a value exactly the same as the active cell just inserted THEN
The Range (1 row up, 1 column right) to (1 row up, 3 columns right) COPY Destination of copied cells is (ActiveCells row, 1 column right)


Hope this helps.

Coops

P.S. changed the line of code to insert an entire new row rather than a new cell which made more sense to me.

 

[LBinGA]

Thanks so much. I added the code to my worksheet and it's still adding a new row but not copying down to the active row the cells above. Ironically, if I take this code and put it in another, blank worksheet as a test (which I did), it works perfectly.

I formatted the test sheet as a Table and it still works. Not sure what code could be interfering with this. Thoughts?

It was already adding a new row without the .EntireRow.Insert...I'm thinking because it's formatted as a Table, but I changed it anyway as it's probably good practice.

The full code on that sheet is as follows:

Option Explicit

Private Sub Worksheet_SelectionChange(ByVal Target As Range)


    On Error Resume Next
    
    HighlightTableRow Target


End Sub
Sub InsertCompany()
Dim sNewName As String
Dim lPosition As Long
Dim rEmpList As Range


Set rEmpList = Range("D1:D1000")


sNewName = InputBox("Enter Name of Company for added Contact")
On Error Resume Next 'if employee needs to go at start of list, Match will return [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=NA]#NA[/URL] 
lPosition = Application.WorksheetFunction.Match(sNewName, rEmpList, 1)
On Error GoTo 0 'revert to normal error handling (crashing)
rEmpList(lPosition + 1).EntireRow.Insert
rEmpList(lPosition + 1).Value = sNewName
rEmpList(lPosition + 1).Activate


If ActiveCell.Offset(-1, 0).Value = ActiveCell.Value Then
    Range(ActiveCell.Offset(-1, 1), ActiveCell.Offset(-1, 3)).Copy ActiveCell.Offset(0, 1)
    End If
End Sub

Thanks again!

LBinGA

 

[cooper645]

I have absolutely no clue, I copied your code, it did a couple of weird operations first like replace a line and then add to the bottom, then it just started working as normal after I re pasted the info in. Couldn't replicated any faults from there.

 

[LBinGA]

It's working! I had been messing around with this code and apparently put it in a Module as well as the Sheet. When I made the correction in the code you provided, I made it to the sheet code and not in the Module, so it wasn't even looking at the correction. Amateur mistake.
It works perfectly now.

Thanks again!!!

 

[LBinGA]

What if I wanted just certain columns? How would that change the code?

For instance, say I wanted to just copy down Columns 3, 6, 7 & 10 only?

LBinGA

 

[LBinGA]

I worked with it this morning and figured it out. Posting for others in case they need a solution such as this in future.

I have 15 columns of data. I only wanted to copy down the data in columns 1, 5, 11, 12 & 13 once a new Row as added, based on a match of the Row & Column above it, as follows:

Sub InsertCompany()Dim sNewName As String
Dim lPosition As Long
Dim rEmpList As Range


Set rEmpList = Range("C3:C1000")


sNewName = InputBox("Enter Name of New Company")
On Error Resume Next 'if Company needs to go at start of list, Match will return [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=NA]#NA[/URL] 
lPosition = Application.WorksheetFunction.Match(sNewName, rEmpList, 1)
On Error GoTo 0 'revert to normal error handling (crashing)
rEmpList(lPosition + 1).EntireRow.Insert
rEmpList(lPosition + 1).Value = sNewName
rEmpList(lPosition + 1).Activate


If ActiveCell.Offset(-1, 0).Value = ActiveCell.Value Then
    Range(ActiveCell.Offset(-1, 1), ActiveCell.Offset(-1, 1)).Copy ActiveCell.Offset(0, 1)
    Range(ActiveCell.Offset(-1, 5), ActiveCell.Offset(-1, 5)).Copy ActiveCell.Offset(0, 5)
    Range(ActiveCell.Offset(-1, 11), ActiveCell.Offset(-1, 11)).Copy ActiveCell.Offset(0, 11)
    Range(ActiveCell.Offset(-1, 12), ActiveCell.Offset(-1, 12)).Copy ActiveCell.Offset(0, 12)
    Range(ActiveCell.Offset(-1, 13), ActiveCell.Offset(-1, 13)).Copy ActiveCell.Offset(0, 13)
    End If


End Sub

Thanks again!

 

[cooper645]

Congratulations,

I was going to edit it for you at work but the computer system wasn't playing ball. Just logged in at home to find you figured it out.
If you need any more help with this. then please message me direct as I will now cancel my subscription as the matter appears solved.

Kindest Regards,

Coops