VBA to insert new row if cell contains certain symbol

[ky90]

Good day all,

I am new to excel VBA. I am currently using excel version 2003-2007 and trying to use VBA to
1) Insert a new row below if a particular cell in Column A contains either "(" or "@"
2) cut and paste the data after "(" or "@" into the new row
3) copy the rest of the data into the new row
4) adding 1.1 / 1.2 / 1.3 after the value in Column B
until the end of the file

Really appreciate any help. Before and after as shown below. Thanks in advance.

>>>>

Regards,
KY

 

[Sequoyah]

Hi ki90,
try the following code, adapt the sheet name in the code if necessary. Note that the column containing the gender of the people is not handled automatically

Sub kyForum()
'https://www.mrexcel.com/board/threads/vba-to-insert-new-row-if-cell-contains-certain-symbol.1264515/

    Dim ws As Worksheet
    Dim lastRow As Long, i As Long, j As Long
    Dim MyNames() As String, MyID As String, Gender As String
    Dim Suffix As Integer
    
    Set ws = ThisWorkbook.Sheets("Sheet1") '<<===== ADAPT sheet name if needed
    lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
    
    For i = lastRow To 2 Step -1
        If InStr(ws.Cells(i, 1).Value, "@") > 0 Or InStr(ws.Cells(i, 1).Value, "(") > 0 Then
            
            If InStr(ws.Cells(i, 1).Value, "@") > 0 Then
                MyNames = Split(ws.Cells(i, 1).Value, "@")
            ElseIf InStr(ws.Cells(i, 1).Value, "(") > 0 Then
                
                MyNames = Split(Replace(ws.Cells(i, 1).Value, "(", "@"), "@")
                MyNames(1) = Replace(MyNames(1), ")", "")
            End If
            
            MyID = ws.Cells(i, 2).Value
            Gender = ws.Cells(i, 3).Value
            Suffix = 1
                      
            ws.Cells(i, 1).Value = Trim(MyNames(0))
            ws.Cells(i, 2).Value = MyID & " 1." & Suffix
            Suffix = Suffix + 1
            
             For j = 1 To UBound(MyNames)
                ws.Rows(i + j).Insert Shift:=xlDown
                ws.Cells(i + j, 1).Value = Trim(MyNames(j))
                ws.Cells(i + j, 2).Value = MyID & " 1." & Suffix
                ws.Cells(i + j, 3).Value = Gender
                Suffix = Suffix + 1
            Next j
        End If
    Next i
    
End Sub