Issue to delete a line in a FindNext loop - excel

Question

With this code I'm trying to search cells in a column where there is a comma character, and divide it into 2 new cells.
Next I want to Delete the original line, but it seems impossible as the value is used in FindNext operation.
What I have :
Column D Column E
Carrot Vegetable
Apple,Banana Fruit
What I need :
Column D Column E
Carrot Vegetable
Apple Fruit
Banana Fruit
What I've done :
Sub newentry()
'
' newentry Macro
'
Dim line
Dim col
Dim content
With Sheets("Feuil3").Columns("D")
Set c = .Find(",", LookIn:=xlValues)
If Not c Is Nothing Then
firstAddress = c.Address
Do
c.Select
line = ActiveCell.Row
col = ActiveCell.Column
content = ActiveCell
category = Cells(line, "E")
Dim Table() As String
Dim i As Integer
'split content in a table
Table = Split(content, ",")
'loop on table
For i = 0 To UBound(Table)
'copy result on next line
Rows(line + 1).Insert
Tableau(i) = Application.WorksheetFunction.Trim(Table(i))
Cells(line + 1, col).Value = Table(i)
Cells(line + 1, "E").Value = category
Next i
Set c = .FindNext(c)
If c Is Nothing Then
GoTo DoneFinding
End If
'where/how to do this ?
Rows(c.Row).Delete Shift:=xlUp
Loop While Not c Is Nothing And c.Address <> firstAddress
End If
DoneFinding:
End With
End Sub
How can I delete the line that I just found ?
Thanks.

Answer 1

Say we have data in column D like:
Running this short macro:
Sub Restructure()
Dim N As Long, i As Long, j As Long
Dim arr1, arr2, arr3, a1, s As String
N = Cells(Rows.Count, "D").End(xlUp).Row
j = 1
arr1 = Range("D1:D" & N)
For Each a1 In arr1
s = Mid(a1, 2, Len(a1) - 2)
If InStr(s, ",") = 0 Then
Cells(j, "E").Value = "[" & s & "]"
j = j + 1
Else
arr2 = Split(s, ",")
For Each a2 In arr2
Cells(j, "E").Value = "[" & a2 & "]"
j = j + 1
Next a2
End If
Next a1
End Sub
will produce this in column E:
NOTE:
The original data is not disturbed.

Answer 2

insert as many lines as needed minus one below the found cell,
then simply write needed data including found cell row
don't rely on any ActiveCell, just use the c range object you found
Sub newentry()
'
' newentry Macro
'
Dim content As String, Category As String
Dim c As Range
Dim Table() As String
With Sheets("Feuil3").Columns("D")
Set c = .Find(",", LookIn:=xlValues)
If Not c Is Nothing Then
Do
content = c
Category = c.Offset(, 1).Value2
'split content in a table
Table = Split(content, ",")
c.Offset(1).EntireRow.Resize(UBound(Table)).Insert ' insert as many rows needed minus one below the found cell
c.Resize(UBound(Table) + 1).Value = Application.Transpose(Table) ' write contents in as many cells as needed, including the found one
c.Offset(, 1).Resize(UBound(Table) + 1).Value = Array(Category, Category) ' write category in as many cells as needed one column to the right of found one
Set c = .FindNext(c)
Loop While Not c Is Nothing
End If
End With
End Sub

Answer 3

Try this code
Sub Test()
Dim a, b, x, i As Long, j As Long, k As Long
a = Range("D1:E" & Cells(Rows.Count, 1).End(xlUp).Row).Value
ReDim b(1 To UBound(a) * 3, 1 To UBound(a, 2))
For i = LBound(a) To UBound(a)
If InStr(a(i, 1), ",") > 0 Then
x = Split(a(i, 1), ",")
For j = LBound(x) To UBound(x)
k = k + 1
b(k, 1) = Trim(x(j))
b(k, 2) = a(i, 2)
Next j
Else
k = k + 1
b(k, 1) = a(i, 1)
b(k, 2) = a(i, 2)
End If
Next i
Columns("D:E").ClearContents
Range("D1").Resize(k, UBound(b, 2)).Value = b
End Sub