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

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

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

1. 在 Chr(10) 上使用 Split 函数来确定每行所需的字符串。 Chr(10) 是换行符。 Split 会为您生成一个字符串数组。
2. 为您插入正确的行数。
3. 自下而上循环遍历您的范围，以便您处理整个范围。

代码...

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

这很可能不是最简洁的方法，但最终使用@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

Answer 3

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

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

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