如何将多行excel单元转换为多行同时保持其他值相同？

Question

如何将多行单元格转换为多行，同时保持其他单元格中的数据相同。 这是我所拥有的，所需的结果也如下所示。 尝试将文本添加到列，但它将其转换为多列，这不是我要查找的。这是我有超过100行的。

这应该是什么样的。

任何帮助将不胜感激..

Answer 1

这对我有用。

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

Answer 2

假设数据在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