Need help with a script in Excel to insert rows above when duplicates are found

Hi – I run a report out of SQL and into Excel everyday and have a reference (in Col B) which is sometimes duplicated. The reference is numeric and never the same and there can be one that more duplicates of the numeric. For Example:

1,2,2,3 first day

4,5,5,6,6,6,7 second day

I need a script in VBA that will insert a row above where the first duplicate is found so as above:

1,(Insert),2,2,3

4,(Insert),5,5,(Insert),6,6,6,7

Please can someone help before my head explodes? Thanks

Top Contributor Asked on February 22, 2018 in VBA: Basics.
Add Comment
4 Answer(s)

Caveat: Cells B1 and B2 Must not be duplicates.

Note! Change sheet name (“Sheet1”) to your sheet name.

RE: Need help with a script in Excel to insert rows above when duplicates are found

 

[Code]

Sub insertrow()

Dim ws As Worksheet
Set ws = Worksheets(“Sheet1”) ‘ Change this to your sheet name
ws.Activate
Application.ScreenUpdating = False
[B3].Select

Do Until IsEmpty(ActiveCell)

If ActiveCell.Value = ActiveCell.Offset(-1).Value Then

ActiveCell.Offset(-1).EntireRow.Select
Selection.Insert Shift:=xlDown
ActiveCell.Offset(2, 1).Select

Do
If ActiveCell.Value = ActiveCell.Offset(1).Value Then
ActiveCell.Offset(1).Select
Else
Exit Do
End If
Loop

Else
ActiveCell.Offset(1).Select

End If
ActiveCell.Offset(2).Select
Loop
End Sub

Expert Answered on February 22, 2018.
Add Comment

Thanks, that’s much appreciated, however once I’ve run the code it says the subscript is out of range – even if I use it on the same example you have done (Before/After above)… I would assume this is a easy problem to solve alas limited experience… any ideas?

Top Contributor Answered on February 23, 2018.

Sorry I have found an error and I am working on it.

on February 23, 2018.
Add Comment

Ok This should work.  Note you can now have duplicate values in cells B1 and B2.

RE: Need help with a script in Excel to insert rows above when duplicates are found

[Code]

Sub insertrow()

Dim ws As Worksheet
Set ws = Worksheets(“Sheet1”) ‘ Change this to your sheet name
ws.Activate
Application.ScreenUpdating = False
[B1].Select

Do Until IsEmpty(ActiveCell)

If ActiveCell.Value = ActiveCell.Offset(1).Value Then

ActiveCell.EntireRow.Select
Selection.Insert Shift:=xlDown
ActiveCell.Offset(2, 1).Select

Do
If ActiveCell.Value = ActiveCell.Offset(1).Value Then
ActiveCell.Offset(1).Select
Else
Exit Do
End If
Loop

Else
ActiveCell.Offset(1).Select

End If
Loop
End Sub

Expert Answered on February 23, 2018.
Add Comment

Thanks again, however the code above says the sub is out of range – seems to break down on (Set ws = Worksheets(“Sheet1”) ), and yes, I have changed my worksheet to “Sheet1”. However looking back on some previous code I’ve used/seen if I change the first paragraph as per below this seems to work fine for me…

Sub insertrow()
Dim WorkRng As Range
On Error Resume Next
Set WorkRng = Range(“B”)

[B1].Select

Do Until IsEmpty(ActiveCell)

If ActiveCell.Value = ActiveCell.Offset(1).Value Then

ActiveCell.EntireRow.Select
Selection.Insert Shift:=xlDown
ActiveCell.Offset(2, 1).Select

Do
If ActiveCell.Value = ActiveCell.Offset(1).Value Then
ActiveCell.Offset(1).Select
Else
Exit Do
End If
Loop

Else
ActiveCell.Offset(1).Select

End If
Loop
End Sub

…again, many thanks for your help.

Top Contributor Answered on February 28, 2018.

Worksheet out of range error maybe due to your workbook not having a sheet named “Sheet1”. Just a thought?

on March 1, 2018.
Add Comment
  • Found this useful?

    Please share using the share button above.

    If you found the answer is best answer for your question, Please mark as 'best answer' by clicking on the right tick mark icon at the left side of the answer.

    Found the answer useful and wants to credit the user, then vote the answer (vote up).

  • Your Answer

    By posting your answer, you agree to the privacy policy and terms of service.