是否可以将带有换行符的单元格拆分为一个范围内的多行？

Question

我有一系列数据，其中一些单元格有换行符，我需要将换行符拆分为换行符下方的行，但其他单元格保持原样。如果有所不同，也有多个列。

我使用了下面提供的两个答案，并进行了一些调整以适合我的工作表，但都无法拆分所有单元格。我最后甚至都尝试了，但这也不起作用。

当A列有换行符时，它可以工作，但是当A列没有换行符而另一列有时，它就不起作用。如果A列没有换行符，我只需要将有换行符的行拆分并合并到下面的行即可。

代码如下：

end_row = range("A" & Rows.count).End(xlUp).row

range("A:A").TextToColumns Destination:=range("a1"), DataType:=xlDelimited, _
    TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=False, _
    Semicolon:=False, Comma:=False, Space:=False, Other:=False, OtherChar _
    :="   ", FieldInfo:=Array(1, 1), TrailingMinusNumbers:=True

For i = 1 To end_row
    row_added = False
    For j = 1 To 4
        If InStr(1, Cell, Chr(10)) <> 0 Then
            If Not row_added Then
                Rows(i + 1).Insert
                row_added = True
                end_row = end_row + 1
            End If
            Cells(i + 1, j) = Right(Cells(i, j), Len(Cells(i, j)) - InStr(1, Cell, Chr(10)))
            Cells(i, j) = Left(Cells(i, j), InStr(1, Cell, Chr(10)) - 1)
        End If
    Next j
Next i

和

Sub LFtoRow()
Dim myWS As Worksheet, myRng As range
Dim LastRow As Long, iLoop As Long, jLoop As Long
Dim myString() As String

Set myWS = ActiveSheet
LastRow = myWS.Cells(myWS.Rows.count, 1).End(xlUp).row

For iLoop = LastRow To 1 Step -1
    myString = Split(myWS.Cells(iLoop, 1), Chr(10))
    If UBound(myString, 1) > 0 Then
        myWS.Rows(iLoop + 1 & ":" & iLoop + UBound(myString, 1)).Insert shift:=xlShiftDown
        For jLoop = 0 To UBound(myString, 1)
            myWS.Cells(iLoop + jLoop, 1) = myString(jLoop)
        Next jLoop
    End If
Next iLoop

End Sub

要么完全使用新代码，要么只在最后添加一些内容。我有一个正在发生的事情的例子，以及我希望它看起来像下面的样子。（我知道它在照片中显示 B 列，但此时在 MACRO 中它在 A 列中）

发生了什么：

我需要发生的事情：

Answer 1

我会推荐类似于下面的代码来解决您的问题。它具有以下属性：

使用 Split 函数在 Chr(10) 上确定每行所需的字符串。 Chr(10) 是换行符。 Split 为您生成一个字符串数组。
为您插入正确的行数。
从下到上遍历您的范围，以便您处理完整的范围。

代码...

Sub LFtoRow()
Dim myWS As Worksheet, myRng As Range
Dim LastRow As Long, iLoop As Long, jLoop As Long
Dim myString() As String

Set myWS = Worksheets("Sheet1")
LastRow = myWS.Cells(myWS.Rows.Count, 1).End(xlUp).Row

For iLoop = LastRow To 1 Step -1
    myString = Split(myWS.Cells(iLoop, 1), Chr(10))
    If UBound(myString, 1) > 0 Then
        myWS.Rows(iLoop + 1 & ":" & iLoop + UBound(myString, 1)).Insert Shift:=xlShiftDown
        For jLoop = 0 To UBound(myString, 1)
            myWS.Cells(iLoop + jLoop, 1) = myString(jLoop)
        Next jLoop
    End If
Next iLoop

End Sub

当出现此输入时...

...生成此结果...

Answer 2

这是我的建议，应该处理所有列中的换行符。

我还删除了插入“;”的替换然后就此分裂。完整代码为：

end_row = Range("A" & Rows.Count).End(xlUp).Row

Range("A:A").TextToColumns Destination:=Range("a1"), DataType:=xlDelimited, _
    TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=False, _
    Semicolon:=False, Comma:=False, Space:=False, Other:=False, OtherChar _
    :="   ", FieldInfo:=Array(1, 1), TrailingMinusNumbers:=True

For i = 1 To end_row
    row_added = False
    For j = 1 To 4
        If InStr(1, Cell, Chr(10)) <> 0 Then
            If Not row_added Then
                Rows(i + 1).Insert
                row_added = True
                end_row = end_row + 1
            End If
            Cells(i + 1, j) = Right(Cells(i, j), Len(Cells(i, j)) - InStr(1, Cell, Chr(10)))
            Cells(i, j) = Left(Cells(i, j), InStr(1, Cell, Chr(10)) - 1)
        End If
    Next j
Next i

Answer 3

这很可能不是最简洁的方法，但使用@OldUgly 的代码最终对我有用。

Sub LFtoRow()
Dim myWS As Worksheet, myRng As range
Dim LastRow As Long, iLoop As Long, jLoop As Long
Dim myString() As String

Set myWS = ActiveSheet
LastRow = myWS.Cells(myWS.Rows.count, 1).End(xlUp).row

For iLoop = LastRow To 1 Step -1
    myString = Split(myWS.Cells(iLoop, 1), Chr(10))
    If UBound(myString, 1) > 0 Then
        myWS.Rows(iLoop + 1 & ":" & iLoop + UBound(myString, 1)).Insert shift:=xlShiftDown
        For jLoop = 0 To UBound(myString, 1)
            myWS.Cells(iLoop + jLoop, 1) = myString(jLoop)
        Next jLoop
    End If
Next iLoop

For iLoop = LastRow To 1 Step -1
    myString = Split(myWS.Cells(iLoop, 2), Chr(10))
    If UBound(myString, 1) > 0 Then
        For jLoop = 0 To UBound(myString, 1)
            myWS.Cells(iLoop + jLoop, 2) = myString(jLoop)
        Next jLoop
    End If
Next iLoop

For iLoop = LastRow To 1 Step -1
    myString = Split(myWS.Cells(iLoop, 3), Chr(10))
    If UBound(myString, 1) > 0 Then
        For jLoop = 0 To UBound(myString, 1)
            myWS.Cells(iLoop + jLoop, 3) = myString(jLoop)
        Next jLoop
    End If
Next iLoop

For iLoop = LastRow To 1 Step -1
    myString = Split(myWS.Cells(iLoop, 4), Chr(10))
    If UBound(myString, 1) > 0 Then
        For jLoop = 0 To UBound(myString, 1)
            myWS.Cells(iLoop + jLoop, 4) = myString(jLoop)
        Next jLoop
    End If
Next iLoop

For iLoop = LastRow To 1 Step -1
    myString = Split(myWS.Cells(iLoop, 5), Chr(10))
    If UBound(myString, 1) > 0 Then
        For jLoop = 0 To UBound(myString, 1)
            myWS.Cells(iLoop + jLoop, 5) = myString(jLoop)
        Next jLoop
    End If
Next iLoop

End Sub

是否可以将带有换行符的单元格拆分为一个范围内的多行？

Is it possible to split cells with line breaks into multiple rows in a range?

excel

vba

line-breaks