VBA to copy and insert below when value is found

[bettlejus]

Dear all,

I need a VBA that finds a value found multiple times in a row and when it finds the value will copy the row where the value is and insert it below.

So far I have:

Sub copy_insert()
Dim c As Range
For Each c In Range("A1:A30")
If c.Value = "aaa" Then
c.EntireRow.Copy
c.Offset(1, 0).EntireRow.Insert
End If
Next c
End Sub

But this will always fail, if I comment the Insert or the copy line will work, but both together, no.

Please help me with a fix.

Thank you!

 

[wideboydixon]

The problem you have is that the range is extending each time. Consider you have "aaa" in A1. Row 1 will be copied and inserted on row 2. The original range is now A1:A31 and the next cell considered will be A2 which now contains "aaa" so another line will be inserted. It's going to loop forever and since you don't have a "DoEvents" in there it's going to go into "Not Responding" mode. This might suit you better:

Sub copy_insert()

Dim thisRow As Long

For thisRow = 30 To 1 Step -1
    If Cells(thisRow, 1).Value = "aaa" Then
        Rows(thisRow).Copy
        Rows(thisRow + 1).Insert
        DoEvents
    End If
Next thisRow

Application.CutCopyMode = False

End Sub

WBD

 

[bettlejus]

Thank you Dixon, that works!