How to loop the split of different cells with line breaks into one cell with line breaks (VBA Excel)

Question

I discovered programming and VBA 5 days ago. I completely overestimated my abilities to master this subject quickly. I am getting more humble now. I really know nothing about the subject. It's bigger than I thought. After two or three sleepless nights I decided to ask for your help.

I have a table with 5 columns and thousands of rows.

For each row, I would like to split the content of the cells from columns A, B, C, D and merge these strings of data into a single cell in column E. From what I understood the function to use is the SPLIT function a carriage return CHR(10) as a delimiter. There is no data in the cells from column D for the moment.

For each cells of columns A, B, C and D in a single row, there are always the same number of line breaks. I would like the different strings of data from cells in columns A, B, C and D to appear side by side sperated by a space in the cell of column E just as shown in the drawing below and on the pictures attached. Obviously the cell in column E will have the same number of lines breaks than the cells of the same row.

I would like to loop the process in order to achieve this for every rows of the table.

I won't show you my code because you will laugh.

Many thanks for your help.

    |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     |
    |--------|--------|--------|--------|---------------------------|

SCREEN CAPTURE OF THE SITUATION NOW SCREEN CAPTURE OF DESIRED RESULT

Answer 1

I tested this code on 10 rows and it works as expected but Column E will need to be resized manually. It seems that Columns("E").AutoFit is not working here due to the presence of Chr(10)

---

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

This will not work if you have varying instances of line breaks - since you directly state that the instances will always be equal, this should suffice

Answer 2

I won't show you my code because you will laugh.

No one at Stack Overflow will ever laugh or mock any OP's attempt to learn and expand their horizons. This network exists solely to encourage other developers to be the best, most knowledgeable developers they can be and to ask the questions that will help get them there.

It is always helpful to show your code for the sake of those who may be helping you.

To move on to your question, the code below will do exactly what you're looking for assuming that your cells always have the same number of delimiters.

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

That being said, if you ever have varying numbers of delimiters, you'll have issues. You'd want to go a more dynamic route and incorporate an error handler to handle those cases along with a quick check to see which cell has the largest number of delimiters so you don't miss any data:

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

Answer 3

Another alternative approach with 2D Array with out error handler

    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

Answer 4

Formula in E2: =CombineCells(A2:D2)

result:

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

Answer 5

A Split Join Spectacle

Adjust the values in the constants section to fit your needs.

Image

The Code

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