Re-distribute content so every cell within the same row has a similar amount of lines

[andnand]

Hi Everybody,

I have the following:
- Based on the content in column A
- Content is one or more lines, separated by char(13), every line with a different length

The following workbook does the following:
- Splits the lines in the adjacent cells
- Cell length limit is 220
- No line is broken between cells
- Every content from column A produces a different amount of splitting cells
- Only 5 cells/rows with content in attachment, number of rows can be 1000.

The problem is sometimes last cells have very few lines compared to the previous ones within the same row.

How do I redistribute the content so (on each row):
- The amount of lines per cell is similar
- The number of cells with content per row is exactly the same as with the current code
- The length limit of the cell remains 220
- No line is broken between cells

Thank you!!

Sub SplitContent()
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim sourceRange As Range
    Dim targetRange As Range
    Dim cell As Range
    Dim sourceText As String
    Dim lines() As String
    Dim resultLines() As String
    Dim resultIndex As Long
    Dim line As String
    Dim i As Long
    
    Set ws = ThisWorkbook.Sheets("Sheet1")
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    Set sourceRange = ws.Range("A2:A" & lastRow)
    
    For Each cell In sourceRange
        sourceText = cell.Value
        lines = Split(sourceText, Chr(13))
        resultIndex = 0
        ReDim resultLines(0 To 0)
        
        For i = LBound(lines) To UBound(lines)
            If Len(resultLines(resultIndex)) + Len(lines(i)) + 1 <= 220 Then
                resultLines(resultIndex) = resultLines(resultIndex) & lines(i) & Chr(13)
            Else
                resultIndex = resultIndex + 1
                ReDim Preserve resultLines(0 To resultIndex)
                resultLines(resultIndex) = lines(i) & Chr(13)
            End If
        Next i
        
        For i = 0 To UBound(resultLines)
            ws.Cells(cell.Row, i + 2).Value = Left(resultLines(i), Len(resultLines(i)) - 1)
        Next i
    Next cell
End Sub

 

[Marc L]

Hi, two points :​

• your attachment looks like a bad text file import. If it is the case, the better could be to start from the text file, to attach …
• According to your attachment - or to the text file to be attached - attach at least a worksheet with the exact expected result.

Hoping the source data well reflect all the possible cases …​

​

 

[andnand]

As requested, screenshots are attached, and the workbook is updated....

 

[Frank2021]

Hi,

Give it a try and comment

Regards

 

[Marc L]

It's maybe not the expected order - result in OriginalData!C:E - but as this is the obvious easy fast way according to post #3 attachment :​

Sub Demo1()
    Dim V, W(), R&, C%, X
   With Sheet2.UsedRange.Rows
        V = .Columns(1)
        ReDim W(2 To .Count, 2)
    For R = 2 To .Count
        C = -1
    For Each X In Split(V(R, 1), vbCr)
        C = (C + 1) Mod 3
        W(R, C) = W(R, C) & X & vbLf
    Next X, R
        With .Range("C2:E" & .Count):  .ColumnWidth = 255:  .VerticalAlignment = xlTop:  .Value2 = W:  .Columns.AutoFit:  End With
   End With
End Sub

Do you like it ? So thanks to click on bottom right Like !​

​

 

[Marc L]

After the easy obvious horizontal distribution, according to post #3 the vertical distribution VBA demonstration for starters :​

Sub Demo2()
    Dim V, T$(), R&, L&, S$(), C%
   With Sheet2.UsedRange.Rows
        V = .Columns(1)
        ReDim T(2 To .Count, 2)
    For R = 2 To .Count
        L = 0
        S = Split(V(R, 1), vbCr)
    For C = 0 To 2
    For L = L To L - 1 + (UBound(S) + 1 - L) / (3 - C)
        T(R, C) = T(R, C) & S(L) & vbLf
    Next L, C, R
         .Columns(2) = " "
         .Columns(1).WrapText = False
    With .Range("C2:E" & .Count)
         .ColumnWidth = 255
         .VerticalAlignment = xlTop
         .Value2 = T
         .Columns.AutoFit
         .Rows.AutoFit
    End With
         .Columns(1).VerticalAlignment = xlCenter
   End With
End Sub

You should Like it !​

​

 

[andnand]

Hi,

Give it a try and comment

Regards

Thank you for the effort, definitely not what I wanted...

 

[andnand]

After the easy obvious horizontal distribution, according to post #3 the vertical distribution VBA demonstration for starters :​

Sub Demo2()
    Dim V, T$(), R&, L&, S$(), C%
   With Sheet2.UsedRange.Rows
        V = .Columns(1)
        ReDim T(2 To .Count, 2)
    For R = 2 To .Count
        L = 0
        S = Split(V(R, 1), vbCr)
    For C = 0 To 2
    For L = L To L - 1 + (UBound(S) + 1 - L) / (3 - C)
        T(R, C) = T(R, C) & S(L) & vbLf
    Next L, C, R
         .Columns(2) = " "
         .Columns(1).WrapText = False
    With .Range("C2:E" & .Count)
         .ColumnWidth = 255
         .VerticalAlignment = xlTop
         .Value2 = T
         .Columns.AutoFit
         .Rows.AutoFit
    End With
         .Columns(1).VerticalAlignment = xlCenter
   End With
End Sub

You should Like it !​

​

Thank you!, Almost there, the cell limit is 220 in length, amount of columns should be the same as the original code produced...if a cell in Col A is 10x the current sample data, we will have many columns with content...Also, I tried to make a larger cell in Col A and somehow didn't recognize the line brakes...

 

[Marc L]

As I wrote « according to post #3 attachment » where the 220 length limit has no sense as never reached and​

like I warned in post #2 : « Hoping the source data well reflect all the possible cases » …​

​

If the length limit is the main criteria then you must explain at least your strategy to calculate the necessary number of columns​

before to process the split. Without any, stay with your original code, just replace vbCr with vbLf​

then if really necessary you can add a new process to compare cells row by row in order to fix each row last cell.​

​

As the easy coding way is the horizontal distribution …​

​

 

[andnand]

The code I provided originally covered the 220 and resulted in the right amount of columns (which is the minimum possible based on length). All I wanted, and don't know how to do, was to refactor the code so it rebalances all cells in a row so they have a similar amount of lines (for printing purposes). Sorry, I didn't supply source data to reflect all the possible cases.

I tried to make the post comply with rules and details, and based on your comments I am 100% sure that you know what I wanted to achieve, and I truly appreciate the code provided, but I don't know how to read you and I am confused with your comments.

 

[Marc L]

So without any smart attachment maybe :​

Sub Demo1L()
    Dim R&, K%, L&, S, V, C&, W()
   With Sheet2
       .UsedRange.Offset(, 1).Clear
        Application.ScreenUpdating = False
    For R = 2 To .[A1].End(xlDown).Row
        K = 1
        L = 0
        S = Split(.Cells(R, 1), vbCr)
    For Each V In S
        C = Len(V) + 1
        L = L + C
        If L > 220 Then K = K + 1: L = C
    Next
        C = -1
        ReDim W(K - 1)
    For Each V In S
        C = (C + 1) Mod K
        W(C) = W(C) & V & vbLf
    Next
       .Cells(R, 3).Resize(, K) = W
    Next
    With .UsedRange.Columns(3).Resize(, .UsedRange.Columns.Count - 2)
         .ColumnWidth = 255
         .VerticalAlignment = xlTop
         .AutoFit
    End With
        Application.ScreenUpdating = True
   End With
End Sub

Do you like it ? ► ► So thanks to click on bottom right Like ! ◄ ◄​

​

 

[andnand]

Hi Marc, merci!!!... Do you offer consulting or professional services? please let me know. Thank you again!!!

 

[Marc L]

In case my last VBA demonstration fails with the length limit​

- as it's a vertical 220 length limit calculation but the distribution is done horizontally, few chance, close to zero percent but may occur -​

so according to my post #9 as a 'spare' your original VBA procedure revamped with free 'consulting comments' :​

Sub SplitContent()
'    Dim ws As Worksheet            ' useless !
'    Dim lastRow As Long            ' useless !
'    Dim sourceRange As Range       ' useless !
'    Dim targetRange As Range       ' LoL not even used !!
    Dim cell As Range
'    Dim sourceText As String       ' useless !
    Dim lines() As String
    Dim resultLines() As String
    Dim resultIndex As Long
'    Dim line As String             ' LoL not even used !!
    Dim i As Long

'    Set ws = ThisWorkbook.Sheets("Sheet1")                         ' CRASHES !! And useless !
'    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row           ' useless !
'    Set sourceRange = ws.Range("A2:A" & lastRow)                   ' useless !

    For Each cell In Sheet2.Range("A2", Sheet2.[A1].End(xlDown))
'        sourceText = cell.Value                                    ' useless !
        lines = Split(cell, vbCr)
        resultIndex = 0
        ReDim resultLines(0)

        For i = 0 To UBound(lines)
            If Len(resultLines(resultIndex)) + Len(lines(i)) + 1 <= 220 Then
                resultLines(resultIndex) = resultLines(resultIndex) & IIf(resultLines(resultIndex) > "", vbLf, "") & lines(i)
            Else
                resultIndex = resultIndex + 1
                ReDim Preserve resultLines(resultIndex)
                resultLines(resultIndex) = lines(i)
            End If
        Next i

'------ New process
        If resultIndex > 0 Then
                lines = Split(resultLines(resultIndex - 1), vbLf)
            If UBound(lines) - UBound(Split(resultLines(resultIndex), vbLf)) > 1 Then
                resultLines(resultIndex - 1) = Left(resultLines(resultIndex - 1), InStrRev(resultLines(resultIndex - 1), vbLf) - 1)
                resultLines(resultIndex) = lines(UBound(lines)) & vbLf & resultLines(resultIndex)
            End If
        End If
'------

'        For i = 0 To resultIndex
        cell(1, 2).Resize(, resultIndex + 1) = resultLines
'        Next i
    Next cell
End Sub