Copy paste entire row below the cell that contain specific word

[iamalvin]

Good day to you all.
As the title implies, I would like to copy entire row and paste it at the SAME WORKSHEET below the cell that contain specific word. For example,
[TABLE="class: grid, width: 500"]
<tbody>[TR]
[TD]A[/TD]
[TD]B[/TD]
[TD]C[/TD]
[/TR]
[TR]
[TD]XXXXXX[/TD]
[TD]ABCDEFG/123456[/TD]
[TD]YYYYY[/TD]
[/TR]
</tbody>[/TABLE]

I would like to change the above table to :
[TABLE="class: grid, width: 500"]
<tbody>[TR]
[TD]A[/TD]
[TD]B[/TD]
[TD]C[/TD]
[/TR]
[TR]
[TD]XXXXXX[/TD]
[TD]ABCDEFG/123456[/TD]
[TD]YYYYY[/TD]
[/TR]
[TR]
[TD]XXXXXX[/TD]
[TD]ABCDEFG/123456[/TD]
[TD]YYYYY[/TD]
[/TR]
</tbody>[/TABLE]

The specific text i meant was this symbol "/". So if column B contains 2 "/", then 2 additional row will be added below the original row.
I have a macro that could possibly do this but end up giving me an error. I would really appreciate if someone could point out where is the error.

Sub Insert_CopyPaste()


    Dim LastRow As Long, I As Long, txt As String
    txt = "/" 'set text to search
    With Sheets("Sheet9")


        LastRow = .Range("B6000").End(xlUp).Row
        Do While I <= LastRow


            If .Range("C" & I).Value = "/" Then


                .Range("a" & I).EntireRow.Copy
                .Range("a" & I + 1).EntireRow.Insert
                .Range("a" & I + 1).PasteSpecial xlPasteValues
        


            End If


            I = I + 1 'goto next row to check


        Loop
    End With
End Sub

Thank you!

 

[JackDanIce]

Try:

Sub InsertCopyPaste()

    Dim LR          As Long
    Dim LC          As Long
    Dim x           As Long
    Dim strCount    As Long
    
    LR = Cells(Rows.count, 1).End(xlUp).row
    LC = Cells(1, Columns.count).End(xlToLeft).column
    
    Application.ScreenUpdating = False
    
    For x = LR To 2 Step -1
        strCount = Len(Cells(x, 2).Value) - Len(Replace(Cells(x, 2).Value, "/", vbNullString))
        If strCount > 0 Then
            Cells(x + 1, 1).Resize(strCount, LC).EntireRow.Insert
            Cells(x, 1).Resize(strCount + 1, LC).FillDown
            strCount = 0
        End If
    Next x

    Application.ScreenUpdating = True

End Sub