Thread: Copy row based on criteria & clean up record

if you're not concerned about the rows being next to each other, this should work

Sub ParsePounds()
    Dim rSearch     As Range
    Dim rFound      As Range
    Dim vParse      As Variant
    Dim vItem       As Variant
    Const cItem = ";#"
    
    Set rSearch = Range(Cells(2, "E"), Cells(Rows.Count, "E").End(xlUp))
    Set rFound = rSearch.Find(cItem, LookIn:=xlValues, LookAt:=xlPart)

    Do Until rFound Is Nothing
        vParse = Split(rFound.Text, cItem)
        For Each vItem In vParse
            If vItem = vParse(0) Then
                rFound = vItem
            Else
                Rows(Cells(Rows.Count, "A").End(xlUp).Offset(1).Row).Value = Rows(rFound.Row).Value
                Cells(Rows.Count, "E").End(xlUp) = vItem
            End If
        Next
        Set rFound = rSearch.FindNext(rFound)
    Loop
    
    Set rSearch = Nothing
End Sub

If you do have data following the row(s) you're fixing and want to keep the new rows all together, this code would be better

Sub ParsePounds()
    Dim rSearch     As Range
    Dim rFound      As Range
    Dim vParse      As Variant
    Dim vItem       As Variant
    Const cItem = ";#"
    
    Set rSearch = Range(Cells(2, "E"), Cells(Rows.Count, "E").End(xlUp))
    Set rFound = rSearch.Find(cItem, LookIn:=xlValues, LookAt:=xlPart)
    
    Do Until rFound Is Nothing
        vParse = Split(rFound.Text, cItem)
        For Each vItem In vParse
            If vItem = vParse(0) Then
                rFound = vItem
            Else
                Rows(rFound.Row).Offset(1).Insert shift:=xlDown
                Rows(rFound.Row).Offset(1).Value = Rows(rFound.Row).Value
                Cells(rFound.Row, "E").Offset(1) = vItem
            End If
        Next
        Set rFound = rSearch.FindNext(rFound)
    Loop
    
    Set rSearch = Nothing
End Sub

One more modification...This one keeps them in the same order they were originally listed in.

Option Explicit

Sub ParsePounds()
    Dim rSearch     As Range
    Dim rFound      As Range
    Dim vParse      As Variant
    Dim vItem       As Variant
    Dim iCount      As Integer
    Dim bScrUpd     As Boolean
    Dim bEvents     As Boolean
    Dim lCalc       As Long
    Const cItem = ";#"
    
    'Improve performance
    With Application
        bScrUpd = .ScreenUpdating
        bEvents = .EnableEvents
        lCalc = .Calculation
        .ScreenUpdating = False
        .EnableEvents = False
        .Calculation = xlCalculationManual
    End With
    
    Set rSearch = Range(Cells(2, "E"), Cells(Rows.Count, "E").End(xlUp))
    Set rFound = rSearch.Find(cItem, LookIn:=xlValues, LookAt:=xlPart)
    
    Do Until rFound Is Nothing
        iCount = 0
        vParse = Split(rFound.Text, cItem)
        For Each vItem In vParse
            If vItem = vParse(0) Then
                rFound = vItem
            Else
                iCount = iCount + 1
                Rows(rFound.Row).Offset(iCount).Insert shift:=xlDown
                Rows(rFound.Row).Offset(iCount).Value = Rows(rFound.Row).Value
                Cells(rFound.Row, "E").Offset(iCount) = vItem
            End If
        Next
        Set rFound = rSearch.FindNext(rFound)
    Loop
    
    Set rSearch = Nothing
    
    'Restore Application Settings
    With Application
        .ScreenUpdating = bScrUpd
        .EnableEvents = bEvents
        .Calculation = lCalc
    End With
End Sub