发出删除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