Create new row for duplicate cell values

[albie91]

Hello,
I could use some help with a certain topic. I have an Excel sheet with multiple rows and columns. I sorted the rows based on the values in column A. I need to run a VBA script to loop through the worksheet so that whenever a row is found with the same value repeated in column A, a row would be generated on top of it, and the value of column A would be copied. The other cells in this new row shall be empty. So, if the input sheet is as follows:

Name	Property 1	Property 2
ABC	12A	15B
ABC	14	15B
XYZ	5	3
PQR	34C	10
PQR	22A	46B
PQR	15	45R

then, the output sheet would be as follows:

Name	Property 1	Property 2
ABC
ABC	12A	15B
ABC	14	15B
XYZ	5	3
PQR
PQR	34C	10
PQR	22A	46B
PQR	15	45R

It would also be helpful if the newly created rows (if any), are formatted in red color.
My main issue is, how do I ensure that if I re-run the script on the above output, a new row is not added over an already existing empty row.
So if I run the VBA script again, the following should NOT happen:

Name	Property 1	Property 2
ABC
ABC
ABC	12A	15B
ABC	14	15B
XYZ	5	3
PQR
PQR
PQR	34C	10
PQR	22A	46B
PQR	15	45R

Thank you for the time and help.

 

[kweaver]

My amateur VBA might do it until someone does a really slick one.

Sub SpecInsert()
Dim lr As Long, i As Long
lr = Cells(Rows.Count, "A").End(xlUp).Row
For i = lr To 2 Step -1
 If (Cells(i, 1) <> Cells(i - 1, 1)) And (Not IsEmpty(Cells(i, 2))) And (WorksheetFunction.CountIf(Range("A1:A" & lr), Cells(i, 1)) > 1) And Not IsEmpty(Cells(i - 1, 1)) Then
 Cells(i, 1).EntireRow.Insert Shift:=xlShiftDown
 Cells(i, 1) = Cells(i + 1, 1)
 Else
 End If
Next i
End Sub

 

[albie91]

That works perfectly. Thank you!