Проблема удаления строки в цикле FindNext

Question

С помощью этого кода я пытаюсь найти ячейки в столбце, где есть запятая, и разделить его на 2 новые ячейки.

Далее я хочу Удалить исходную строку, но это кажется невозможным, поскольку значение используется в операции FindNext .

Что у меня есть:

Column D       Column E
Carrot         Vegetable 
Apple,Banana   Fruit

Что мне нужно:

Column D       Column E
Carrot         Vegetable 
Apple          Fruit
Banana         Fruit

Что я сделал:

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

Как я могу удалить только что найденную строку?

Спасибо.

Answer 1

Скажем, у нас есть данные в столбце D вроде:

Запуск этого короткого макроса:

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

выдаст это в столбце E :

Примечание:

Исходные данные не нарушаются.

Answer 2

вставьте столько строк, сколько необходимо, минус одна ниже найденной ячейки,

, затем просто запишите необходимые данные, включая найденную строку ячейки

не полагайтесь на ActiveCell, просто используйте объект диапазона c, который вы нашли

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

Попробуйте этот код

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