Как преобразовать многострочную ячейку Excel в многорядную, сохранив при этом другие значения?

Question

Как я могу преобразовать многострочную ячейку в многорядную, сохранив при этом данные в других ячейках.Вот что я имею, и желаемый результат также показан ниже.Пробовал текст в столбец, но он преобразует его в несколько столбцов, что не то, что я ищу.Вот то, что у меня есть более 100 строк.

Вот как это должно выглядеть.

Буду признателен за любую помощь ..

Answer 1

Предполагая, что данные находятся в столбцах A, B и C:

Sub G()

    Dim r&, x&, cnt%, arr
    Dim wksOutput As Worksheet
    Dim this As Worksheet

    x = 2 '//Skip header
    Set this = ActiveSheet
    Set wksOutput = Sheets.Add(After:=Sheets(Sheets.Count))

    With wksOutput
        For r = 2 To this.Cells(Rows.Count, 1).End(xlUp).Row
            arr = Split(this.Cells(r, "C"), Chr(10))
            cnt = UBound(arr) + 1
            .Cells(x, "A").Resize(cnt) = this.Cells(r, "A")
            .Cells(x, "B").Resize(cnt) = this.Cells(r, "B")
            .Cells(x, "C").Resize(cnt) = Application.Transpose(arr)
            x = x + cnt
        Next
    End With

End Sub

Answer 2

это работает для меня.

Sub ConvertMultiLine()

    Dim cellVal     As String
    Dim WrdArray()  As String

    Dim Item        As Variant

    Dim iRow        As Long
    Dim Counter     As Long

    Dim colNum      As Integer  'column number where multi line cells are
        colNum = 3              'e.g. column "C"

    Dim rowStart    As Integer  'row number where the first multiline cell is
        rowStart = 2

    Dim rowPaste    As Integer  'row number where you want to paste the result
        rowPaste = 2            'if rowPaste = rowStart, the data will be overwritten

    Dim Arr()       As String   'array that will contain the separated values


    '1st loop to get the number of items (it's used to skip redim of 2D array)
    iRow = 0
    Counter = 0
    Do Until IsEmpty(ThisWorkbook.ActiveSheet.Cells(rowStart + iRow, colNum))

        'Split content of a cell
        cellVal = ThisWorkbook.ActiveSheet.Cells(rowStart + iRow, colNum).Value
        WrdArray() = Split(cellVal, vbLf)

        'Counting items
        For Each Item In WrdArray
            Counter = Counter + 1
        Next Item

        iRow = iRow + 1
    Loop

    '2nd loop to insert values into array
    iRow = 0
    ReDim Arr(1 To Counter, 1 To 3)
    Counter = 0
    Do Until IsEmpty(ThisWorkbook.ActiveSheet.Cells(rowStart + iRow, colNum))

        'Split content of a cell
        cellVal = ThisWorkbook.ActiveSheet.Cells(rowStart + iRow, colNum).Value
        WrdArray() = Split(cellVal, vbLf)

        'Set items to array
        For Each Item In WrdArray
            Arr(1 + Counter, 1) = ThisWorkbook.ActiveSheet.Cells(rowStart + iRow, colNum - 2)
            Arr(1 + Counter, 2) = ThisWorkbook.ActiveSheet.Cells(rowStart + iRow, colNum - 1)
            Arr(1 + Counter, 3) = Item
            Counter = Counter + 1
        Next Item

        iRow = iRow + 1
    Loop

    'Paste array
    ThisWorkbook.ActiveSheet.Cells(rowPaste, colNum - 2).Resize(Counter, 3) = Arr

End Sub