Разделите ячейки и вставьте в новый ряд

Question

Мои данные включают заголовки. В столбце C ячейки иногда содержат «/» или «,». Цель состоит в том, чтобы разделить эти ячейки и вставить новую строку внизу с каждой подстрокой.

ВХОД

OUTPUT

С помощью приведенного ниже кода я смог заменить все "," на "/". Разделите ячейку в столбце C разделителем «/» и вставьте внизу. Я не смог скопировать и вставить содержимое строки внизу с каждым элементом в массиве функции разделения. Также кажется, что каждый раз вставляются значения разделения, начинающиеся в ячейке C2.

    Sub SuspenseReport()
        Dim SearchCell As Variant
        Dim i As Integer
        Dim cell As Range
        Application.ScreenUpdating = False

        Set Rng = Application.Range("C2:C1000") '*Change Last Row Value Here
        vLr = ActiveCell.SpecialCells(xlLastCell).Row

        For Each cell In Rng
        cell = Replace(cell, ",", "/")

        If InStr(1, cell, "/") <> 0 Then
        SearchCell = Split(cell, "/")
        For i = 0 To UBound(SearchCell)

        Cells(i + 2, 2).Value = SearchCell(i)
        Next i
        End If

        Next cell

        Application.ScreenUpdating = True
   End Sub

Answer 1

При вставке или удалении строк всегда работайте снизу вверх. Чтобы сохранить порядок значения разделения, работайте от последнего к первому.

Option Explicit

Sub splitSlash()
    Dim tmp As Variant, i As Long, j As Long

    With Worksheets("sheet1")
        .Columns("C").Replace what:=Chr(44), replacement:=Chr(47), lookat:=xlPart
        For i = .Cells(.Rows.Count, "A").End(xlUp).Row To 2 Step -1
            tmp = Split(.Cells(i, "C").Value2 & Chr(47), Chr(47))
            For j = UBound(tmp) - 1 To LBound(tmp) + 1 Step -1
                .Cells(i + 1, "A").EntireRow.Insert
                .Cells(i + 1, "A") = .Cells(i, "A").Value2
                .Cells(i + 1, "B") = .Cells(i, "B").Value2
                .Cells(i + 1, "C") = tmp(j)
            Next j
            .Cells(i, "C") = tmp(j)
        Next i
    End With
End Sub