【问题标题】：How to loop the split of different cells with line breaks into one cell with line breaks (VBA Excel)如何将带有换行符的不同单元格的拆分循环成一个带有换行符的单元格（VBA Excel）
【发布时间】：2019-07-03 06:01:55
【问题描述】：

我在 5 天前发现了编程和 VBA。我完全高估了自己快速掌握这门学科的能力。我现在越来越谦虚了。我真的对这个问题一无所知。它比我想象的要大。经过两三个不眠之夜，我决定寻求您的帮助。

我有一个包含 5 列和数千行的表。

对于每一行，我想从 A、B、C、D 列中拆分单元格的内容，并将这些数据字符串合并到 E 列中的单个单元格中。据我了解，要使用的函数是 SPLIT 函数，将回车 CHR(10) 作为分隔符。 D列的单元格中暂时没有数据。

对于单行中的 A、B、C 和 D 列的每个单元格，总是有相同数量的换行符。我希望 A、B、C 和 D 列中的单元格中的不同数据字符串并排显示，并由 E 列单元格中的空格分隔，如下图和所附图片所示。显然 E 列中的单元格与同一行的单元格中的换行数相同。

我想循环这个过程，以便为表格的每一行实现这一点。

我不会给你看我的代码，因为你会笑。

非常感谢您的帮助。

    |COLUMN A|COLUMN B|COLUMN C|COLUMN D|         COLUMN E          |
    |--------|--------|--------|--------|---------------------------|
    |afge    | dddddd | TR1TR1 | uiuiui | afge dddddd TR1TR1 uiuiui |
    |cvc     |  454   | aaaab  | Z3Z3Z3 |    cvc 454 aaab Z3Z3Z3    |    
    |15gh    | 778899 |   68C  |  ZOZO  |  15gh 778899 68C ZOZO     |
    |--------|--------|--------|--------|---------------------------|

现在情况的屏幕截图所需结果的屏幕截图

【问题讨论】：

标签： excel vba loops split

【解决方案1】：

另一种没有错误处理程序的二维数组替代方法

    Sub test()
    Dim LastRow As Long, Rw As Long, Col As Long, MaxLine As Integer, Ln As Integer
    Dim sTxt As Variant, TTxt As String, Tln As String
    Dim Ws As Worksheet
    Dim Arr() As Variant
    Set Ws = ActiveSheet  ' Change to your requirement
    LastRow = Ws.Range("A" & Rows.Count).End(xlUp).Row   ''  Change to your requirement


        For Rw = 2 To LastRow                                ''  May Change to your requirement
        TTxt = ""
        ReDim Arr(3, 0)
        MaxLine = 0
            For Col = 0 To 3                                        ''  May Change to your requirement
            sTxt = Split(Ws.Cells(Rw, Col + 1).Text, Chr(10))
            If UBound(sTxt) > MaxLine Then
                MaxLine = UBound(sTxt)
                ReDim Preserve Arr(3, MaxLine)
                End If
                For Ln = 0 To MaxLine
                    If UBound(sTxt) >= Ln Then
                    Arr(Col, Ln) = sTxt(Ln)
                    Else
                    Arr(Col, Ln) = ""
                    End If
                Next Ln
            Next Col


            For i = 0 To MaxLine
            Tln = ""
                For Col = 0 To 3
                Tln = Tln & IIf(Col = 0, "", " ") & Arr(Col, i)
                Next Col
            TTxt = TTxt & IIf(i = 0, "", Chr(10)) & Tln
            Next i
       Ws.Cells(Rw, 5).Value = TTxt
        Next Rw

'Workaround for Autofit  based on @undearboys suggest
  Ws.Range("A2:E" & LastRow).ColumnWidth = 100
  Ws.Range("A2:E" & LastRow).RowHeight = 100
 Ws.Range("A2:E" & LastRow).VerticalAlignment = xlTop
 Ws.Range("A2:E" & LastRow).Rows.AutoFit
 Ws.Range("A2:E" & LastRow).Columns.AutoFit

End Sub

【讨论】：

不错的方法。现在我们有 3 个代码面临完全相同的问题（Column E 不是自动拟合，因此结果不会立即匹配 OP 所需的结果）
@undearboy 感谢提醒AutoFit，在我的情况下AutoFit 正在工作。还添加了垂直对齐到顶部
已测试但无法正常工作 - 如果您在运行和测试之前缩小列，您将看到相同的结果。它是自动拟合的，但由于Chr(10) 而不是正确的
是的，奇怪的事情正在发生。你是对的，它在第二次运行时不起作用
@undearboy 感谢您的观察。无法解决问题，但添加了 AutoFir 的解决方法。

【解决方案2】：

我在 10 行上测试了这段代码，它按预期工作，但 Column E 需要手动调整大小。由于Chr(10) 的存在，Columns("E").AutoFit 似乎在这里不起作用

Option Explicit

Sub Test()

Dim SplitA, SplitB, SplitC, SplitD
Dim i As Long, j As Long

Dim Final As String

For i = 2 To Range("A" & Rows.Count).End(xlUp).Row
    SplitA = Split(Range("A" & i), Chr(10))
    SplitB = Split(Range("B" & i), Chr(10))
    SplitC = Split(Range("C" & i), Chr(10))
    SplitD = Split(Range("D" & i), Chr(10))

        For j = LBound(SplitA) To UBound(SplitA)
            Final = Final & SplitA(j) & Chr(32) & SplitB(j) & Chr(32) & SplitC(j) & Chr(32) & SplitD(j) & Chr(32) & Chr(10)
        Next j

        Range("E" & i) = Left(Final, Len(Final) - 2)

    SplitA = ""
    SplitB = ""
    SplitC = ""
    SplitD = ""
    Final = ""
Next i

End Sub

如果您有不同的换行实例，这将不起作用 - 因为您直接声明实例将始终相等，这就足够了

【讨论】：

非常感谢 Urdearboy。我粘贴了您的代码，它立即解决了我的问题。我什至可以或多或少地理解您的代码，因此我将能够重用它，以便将来适合我的特定需求。这对我来说是一件紧急的事情，再次非常感谢。
欢迎，既然@undearboy 的回答解决了您的紧迫问题，并且它是最简单直接的回答，请您接受他的回答，以促进 SO 社区精神。（尽管必须指出，这个请求不是来自不成熟的男孩，在我看来，他是在 SO 社区帮助自然并仅以学术兴趣工作的狂热爱好者之一。）
嘿，谢谢@AhmedAU。 OP，您应该接受任何您认为最有帮助的答案。你有几个小时的时间来回答你的问题，你应该在到期的地方给予信任！

【解决方案3】：

分裂加入奇观

调整常量部分中的值以满足您的需要。

图片

代码

Sub SplitJoin()

    Const cSheet As String = "Sheet1"   ' Worksheet
    Const cSource As String = "A:D"     ' Source Columns Range Address
    Const cTarget As Variant = "E"      ' Target Column Letter/Number
    Const cFirstR As Long = 2           ' First Row
    Const cSDel As String = vbLf        ' Split Delimiter
    Const cJDel As String = " "         ' Join Delimiter
    Const cRDel As String = vbLf        ' Join Row Delimiter

    Dim rngLast As Range    ' Last Cell Range in Source Range
    Dim vntAA As Variant    ' Arrays Array
    Dim vntS As Variant     ' Source Array
    Dim vntT As Variant     ' Target Array
    Dim NoR As Long         ' Number of Rows in Source Array
    Dim NoC As Long         ' Number of Columns in Source Array
    Dim i As Long           ' Source, Arrays and Target Array Row Counter
    Dim j As Long           ' Source Array Column Counter
    Dim k As Long           ' Current Split Array Row Counter
    Dim kMax As Long        ' Max Number of Elements in Current Split Array
    Dim NoCur As Long       ' Current Split Array Size (Number of Elements)
    Dim strCur As String    ' Current Split Array String
    Dim strJoin As String   ' Split Array Join String
    Dim strRow As String    ' Row Join String

    ' In Worksheet of This Workbook (i.e. Workbook Containing This Code)
    With ThisWorkbook.Worksheets(cSheet).Columns(cSource)
        ' Find Last Used Cell Range in Source Columns Range.
        Set rngLast = .Find("*", .Cells(1), xlFormulas, , xlByRows, xlPrevious)
        ' When no data is found in Source Column Range (highly unlikely).
        If rngLast Is Nothing Then Exit Sub
        ' Up a level, to Worksheets(cSheet)
        With .Parent
            ' Copy Source Range to Source Array.
            vntS = .Range(.Cells(cFirstR, .Range(cSource).Column), _
                    .Cells(rngLast.Row, .Range(cSource) _
                    .Offset(, .Range(cSource).Columns.Count - 1).Column))
        End With
    End With

    ' In Arrays
    ' Calculate Number of Rows in Source Array.
    NoR = UBound(vntS)
    ' Calculate Number of Columns in Source Array.
    NoC = UBound(vntS, 2)
    ' Resize Arrays Array to Number of Columns in Source Array. It will contain
    ' 'Split' Arrays for each cell in current row of Source Array.
    ReDim vntAA(1 To NoC)
    ' Resize Target Array to Number of Rows in Source Array, but to only one
    ' column (cTarget).
    ReDim vntT(1 To NoR, 1 To 1)
    ' Loop through rows of Source Array.
    For i = 1 To UBound(vntS)
        ' Loop through columns of Source Array.
        For j = 1 To NoC
            ' Split each cell in current row to a Split Array (vntAA(j))
            vntAA(j) = Split(vntS(i, j), cSDel)
            ' Assign size of Current Split Array to variable.
            NoCur = UBound(vntAA(j))
            ' Determine Max Number of Elements in Current Split Array.
            If NoCur > kMax Then kMax = NoCur
        Next
        ' Loop through elements of Split Array.
        For k = 0 To kMax
            ' Loop through Split Arrays.
            For j = 1 To NoC
                ' Due to the possible different sizes of the Split Arrays,
                ' error checking is necessary.
                On Error Resume Next
                ' Assign current Split Array value to a variable to 'force'
                ' error if Current Split Array Row Counter is 'out of bounds'.
                strCur = vntAA(j)(k)
                If Err Then
                    ' Reset (remove) Error.
                    On Error GoTo 0
                  Else
                    ' Check if Current Split Array String contains a value.
                    If strCur <> "" Then
                        ' Append Join Delimiter and Current Split Array String
                        ' to Split Array Join String.
                        strJoin = strJoin & cJDel & strCur
                    End If
                End If
            Next
            ' Append Join Row Delimiter and Split Array Join String to
            ' Row Join String but remove the initial (first) occurrence of
            ' the Join Delimiter (Right).
            strRow = strRow & cRDel & Right(strJoin, Len(strJoin) - Len(cJDel))
            ' Reset Split Array Join String.
            strJoin = ""
        Next
        ' Write Row Joins String to current row of Target (Source) Array, but
        ' remove the initial (first) occurrence of the Join Row Delimiter.
        vntT(i, 1) = Right(strRow, Len(strRow) - Len(cRDel))
        ' Reset Max Number of Elements in Current Split Array.
        kMax = 0
        ' Reset Row Join String.
        strRow = ""
    Next

    ' In Worksheet of This Workbook (i.e. Workbook Containing This Code)
    With ThisWorkbook.Worksheets(cSheet).Cells(cFirstR, cTarget)
        ' Copy Target Array to Target Range.
        .Resize(UBound(vntT)) = vntT
    End With

End Sub

【讨论】：

非常感谢 Vbasic2008。感谢这项令人惊叹且非常详细的工作。感谢灰色的非常详细的解释。这看起来像是我的高级解决方案。感谢您的代码和解释，感谢您，我能够理解新功能。

【解决方案4】：

E2 中的公式：=CombineCells(A2:D2)

结果：

Function CombineCells(actRange As Range) As String

Dim iCt As Integer
Dim myCell As Range
Dim myArr() As String
Dim targetArr() As String
Dim mySize As Integer
Dim resultStr As String

    'Set actRange = Range("B7:D7")

    'split every cell into an array
    myArr = Split(actRange.Cells(1, 1), vbLf)
    mySize = UBound(myArr) - LBound(myArr) + 1
    ReDim targetArr(mySize)

    'copy line per line into target array
    For Each myCell In actRange
        myArr = Split(myCell, vbLf)
        Debug.Print myCell.Address
        mySize = UBound(myArr) - LBound(myArr) + 1
        'targetArr(0) = myArr(0)
        For iCt = 0 To mySize - 1
            targetArr(iCt) = targetArr(iCt) & " " & myArr(iCt)
        Next iCt
    Next myCell

    'remove leading space
    For iCt = 0 To mySize - 1
        targetArr(iCt) = Mid(targetArr(iCt), 2, Len(targetArr(iCt)) - 1)
        Debug.Print targetArr(iCt)
    Next iCt

    'copy targetArray to Cell and add LineFeed
    resultStr = targetArr(0)
    For iCt = 1 To mySize - 1
        resultStr = resultStr & vbLf & targetArr(iCt)
    Next iCt

CombineCells = resultStr
End Function

【讨论】：

非常感谢简单的解决方案。感谢这项伟大的工作。感谢灰色的详细解释。

【解决方案5】：

我不会给你看我的代码，因为你会笑。

Stack Overflow 的任何人都不会嘲笑或嘲笑任何 OP 尝试学习和拓展视野的尝试。该网络的存在只是为了鼓励其他开发人员成为最好、最有知识的开发人员，并提出有助于他们实现目标的问题。

为了帮助你的人而展示你的代码总是有帮助的。

要继续您的问题，假设您的单元格始终具有相同数量的分隔符，下面的代码将完全符合您的要求。

Sub SplitContent()

Dim i As Long
Dim c As Long
Dim delim As Long
Dim dCount As Long
Dim endrow As Long
Dim txtArr

endrow = Range("A" & Rows.Count).End(xlUp).Row '<-this gets the last used row in Column A from the bottom up

For i = 2 To endrow '<- initializes loop for rows 2 to endrow
    delim = Len(Cells(i, 1)) - Len(Replace(Cells(i, 1), Chr(10), "")) '<-get the number of delimiters in the cell
    For dCount = 0 To delim '<- loop for each delimiter
        For c = 1 To 4 '<- initializes loop for columns A:D
            txtArr = Split(Cells(i, c), Chr(10)) '<-split function that you mentioned
            Range("E" & i) = Range("E" & i) & txtArr(dCount) & " " '<- let E = itself + the dCount position of the column
        Next c
        Range("E" & i) = Range("E" & i) & Chr(10) '<- add  carriage return once the column iteration has complete
    Next dCount
    Range("E" & i) = Left(Range("E" & i), Len(Range("E" & i)) - 1) '<- remove extra carriage return
Next i
End Sub

话虽如此，如果您有不同数量的分隔符，您就会遇到问题。您可能希望采用更动态的路线，并结合一个错误处理程序来处理这些情况，同时快速检查哪个单元格的分隔符数量最多，这样您就不会错过任何数据：

Sub SplitContent()

Dim i As Long
Dim c As Long
Dim delim As Long
Dim dCount As Long
Dim endrow As Long
Dim txtArr

On Error GoTo eHandler '<- this will handle cases where the delimiter count is does not match

endrow = Range("A" & Rows.Count).End(xlUp).Row '<-this gets the last used row in Column A from the bottom up

For i = 2 To endrow '<- initializes loop for rows 2 to endrow
    For c = 1 To 4
        If Len(Cells(i, c)) - Len(Replace(Cells(i, c), Chr(10), "")) > delim Then
            delim = Len(Cells(i, c)) - Len(Replace(Cells(i, c), Chr(10), ""))  '<-get the number of delimiters in the cell
        End If
    Next c
    For dCount = 0 To delim '<- loop for each delimiter
        For c = 1 To 4 '<- initializes loop for columns A:D
            txtArr = Split(Cells(i, c), Chr(10)) '<-split function that you mentioned
            Range("E" & i) = Range("E" & i) & txtArr(dCount) & " " '<- let E = itself + the dCount position of the column
        Next c
        Range("E" & i) = Range("E" & i) & Chr(10) '<- add  carriage return once the column iteration has complete
    Next dCount
    Range("E" & i) = Left(Range("E" & i), Len(Range("E" & i)) - 1) '<- remove extra carriage return
    delim = 0
Next i

Exit Sub
eHandler:
If Err.Number = 9 Then
    Resume Next
End If
MsgBox Err.Number & vbCrLf & Err.Description
End Sub

【讨论】：

不错的一个。这与我的问题相同 - 代码完成后，需要手动调整列大小以显示正确的格式（否则 excel 开始创建自己的换行符）
你是绝对正确的。我尝试添加 .AutoFit 并遇到了与您相同的问题。如果你真的想要，我想你可以自动调整前面的列并将它们的宽度添加到一个变量中，将最后一列的列宽大小设置为该总数，但我刚离开我的房子，无法测试它。
这可行，但由于Chr(10) 的存在，其他列将面临完全相同的问题。假设 OP 让它们安装正确，那么是的，那会起作用
实际上，我收回了这一点，因为它首先是导致问题的 chr(10)。
泰特·加林格非常感谢您的评论。下次我会显示我的代码。我的代码是接近那个或 Urdearboy 的代码。它充满了错误，循环不起作用。再次感谢您花费的时间。就个人而言，我手动调整列大小没有问题。