Split lines that have multiline text and single line text.

This is a pretty interesting question and something I saw earlier. I went ahead and wrote a general solution for it, as it seems like a useful bit of code to myself.

There are almost only two assumptions in the data:

• Returns are represented by Chr(10)
  
  either a constant vbLf
  
  .
• Data belonging to a lower row has enough returns to line up. This is similar to your case, as there are characters returned that appear to be lined up the way you want.

Output images enlarged to show all data for A:D

. Note that the code below processes all columns by default and outputs to a new sheet . You can limit the columns if you like, but it was too tempting to make it generic.

code

Sub SplitByRowsAndFillBlanks()

    'process the whole sheet, could be
    'Intersect(Range("B:D"), ActiveSheet.UsedRange)
    'if you just want those columns
    Dim rng_all_data As Range
    Set rng_all_data = Range("A1").CurrentRegion

    Dim int_row As Integer
    int_row = 0

    'create new sheet for output
    Dim sht_out As Worksheet
    Set sht_out = Worksheets.Add

    Dim rng_row As Range
    For Each rng_row In rng_all_data.Rows

        Dim int_col As Integer
        int_col = 0

        Dim int_max_splits As Integer
        int_max_splits = 0

        Dim rng_col As Range
        For Each rng_col In rng_row.Columns

            'splits for current column
            Dim col_parts As Variant
            col_parts = Split(rng_col, vbLf)

            'check if new max row count
            If UBound(col_parts) > int_max_splits Then
                int_max_splits = UBound(col_parts)
            End If

            'fill the data into the new sheet, tranpose row array to columns
            sht_out.Range("A1").Offset(int_row, int_col).Resize(UBound(col_parts) + 1) = Application.Transpose(col_parts)

            int_col = int_col + 1
        Next

        'max sure new rows added for total length
        int_row = int_row + int_max_splits + 1
    Next

    'go through all blank cells and fill with value from above
    Dim rng_blank As Range
    For Each rng_blank In sht_out.Cells.SpecialCells(xlCellTypeBlanks)
        rng_blank = rng_blank.End(xlUp)
    Next

End Sub

      

        
        
        
      

    

How it works

There are comments in the code to highlight what's going on. Here's a high-level overview:

• In general, we iterate over each row of data, processing each column individually.
• The text of the current cell Split
  
  with vbLf
  
  . This gives an array of all individual lines.
• The counter keeps track of the maximum number of rows added (actually rows-1
  
  , since these arrays 0-indexed
  
  .
• Now the data can be displayed on a new sheet. This is easy because we can just dump the array we created for Split
  
  . The only tricky part is getting to the right place on the sheet. To do this, there is a counter for the current column offset and a global counter to determine how many common rows should be offset. Offset
  
  moves us to the right cell; Resize
  
  ensures that all lines are output. Finally, it is required Application.Transpose
  
  because it Split
  
  returns an array of strings and we are dumping the column.
• Update counters. The column offset is incremented each time. The line offset is updated to add enough lines to cover the last maximum ( +1
  
  since this is 0-indexed
  
  )
• Finally, I end up using my waterfall bay (your previous question) in all of the spaces that were created to ensure there are no spaces. I give up on error checking because I am assuming there are spaces.