Split rows that have multiline text and single line text - vba

Question

I'm trying to figure out how to split rows of data where columns B,C,D in the row contain multiple lines and others do not. I've figured out how to split the multi-line cells if I copy just those columns into a new sheet, manually insert rows, and then run the macro below (that's just for column A), but I'm lost at coding the rest.
Here's what the data looks like:
So for row 2, I need it split into 6 rows (one for each line in cell B2) with the text in cell A2 in A2:A8. I also need columns C and D split the same as B, and then columns E:CP the same as column A.
Here is the code I have for splitting the cells in columns B,C,D:
Dim iPtr As Integer
Dim iBreak As Integer
Dim myVar As Integer
Dim strTemp As String
Dim iRow As Integer
iRow = 0
For iPtr = 1 To Cells(Rows.Count, col).End(xlUp).Row
strTemp = Cells(iPtr1, 1)
iBreak = InStr(strTemp, vbLf)
Range("C1").Value = iBreak
Do Until iBreak = 0
If Len(Trim(Left(strTemp, iBreak - 1))) > 0 Then
iRow = iRow + 1
Cells(iRow, 2) = Left(strTemp, iBreak - 1)
End If
strTemp = Mid(strTemp, iBreak + 1)
iBreak = InStr(strTemp, vbLf)
Loop
If Len(Trim(strTemp)) > 0 Then
iRow = iRow + 1
Cells(iRow, 2) = strTemp
End If
Next iPtr
End Sub
Here is a link to an example file (note this file has 4 rows, the actual sheet has over 600): https://www.dropbox.com/s/46j9ks9q43gwzo4/Example%20Data.xlsx?dl=0

Answer 1

This is a fairly interesting question and something I have seen variations of before. I went ahead and wrote up a general solution for it since it seems like a useful bit of code to keep for myself.
There are pretty much only two assumptions I make about the data:
Returns are represented by Chr(10) or which is the vbLf constant.
Data that belongs with a lower row has enough returns in it to make it line up. This appears to be your case since there are return characters which appear to make things line up like you want.
Pictures of the output, zoomed out to show all the data for A:D. Note that the code below processes all of the columns by default and outputs to a new sheet. You can limit the columns if you want, but it was too tempting to make it general.
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 within the code to highlight what is going on. Here is a high level overview:
Overall, we iterate through each row of the data, processing all of the columns individually.
The text of the current cell is Split using the vbLf. This gives an array of all the individual lines.
A counter is tracking the maximum number of rows that were added (really this is rows-1 since these arrays are 0-indexed.
Now the data can be output to the new sheet. This is easy because we can just dump the array that Split created for us. The only tricky part is getting it to the right spot on the sheet. To that end, there is a counter for the current column offset and a global counter to determine how many total rows need to be offset. The Offset moves us to the right cell; the Resize ensures that all of the rows are output. Finally, Application.Transpose is needed because Split returns a row array and we're dumping a column.
Update the counters. Column offset is incremented every time. The row offset is updated to add enough rows to cover the last maximum (+1 since this is 0-indexed)
Finally, I get to use my waterfall fill (your previous question) on all of the blanks cells that were created to ensure no blanks. I forgo error checking because I assume blanks exist.

Answer 2

Thank you for providing a sample. This task was so interesting that I thought of writing the code for that. You are more than welcome to tweak it to your satisfaction, and I hope your team gets to use an RDBMS to manage this kind of data in the future.
Sub OrganizeSheet()
Dim LastRow As Integer
LastRow = GetLastRow()
Dim Barray() As String
Dim Carray() As String
Dim Darray() As String
Dim LongestArray As Integer
Dim TempInt As Integer
Dim i As Integer
i = 1
Do While i <= LastRow
Barray = Split(Range("B" & i), Chr(10))
Carray = Split(Range("C" & i), Chr(10))
Darray = Split(Range("D" & i), Chr(10))
LongestArray = GetLongestArray(Barray, Carray, Darray)
If LongestArray > 0 Then
' reset the values of B, C and D columns
On Error Resume Next
Range("B" & i).Value = Barray(0)
Range("C" & i).Value = Carray(0)
Range("D" & i).Value = Darray(0)
Err.Clear
On Error GoTo 0
' duplicate the row multiple times
For TempInt = 1 To LongestArray
Rows(i & ":" & i).Select
Selection.Copy
Range(i + TempInt & ":" & i + TempInt).Select
Selection.Insert Shift:=xlDown
' as each row is copied, change the values of B, C and D columns
On Error Resume Next
Range("B" & i + TempInt).Value = Barray(TempInt)
If Err.Number > 0 Then Range("B" & i + TempInt).Value = ""
Err.Clear
Range("C" & i + TempInt).Value = Carray(TempInt)
If Err.Number > 0 Then Range("C" & i + TempInt).Value = ""
Err.Clear
Range("D" & i + TempInt).Value = Darray(TempInt)
If Err.Number > 0 Then Range("D" & i + TempInt).Value = ""
Err.Clear
On Error GoTo 0
Application.CutCopyMode = False
Next TempInt
' increment the outer FOR loop's counters
LastRow = LastRow + LongestArray
i = i + LongestArray
End If
i = i + 1
Loop
End Sub
' ----------------------------------
Function GetLongestArray(ByRef Barray() As String, ByRef Carray() As String, ByRef Darray() As String)
GetLongestArray = UBound(Barray)
If UBound(Carray) > GetLongestArray Then GetLongestArray = UBound(Carray)
If UBound(Darray) > GetLongestArray Then GetLongestArray = UBound(Darray)
End Function
' ----------------------------------
Function GetLastRow() As Integer
Worksheets(1).Select
Range("A1").Select
Selection.End(xlDown).Select
GetLastRow = Selection.Row
Range("A1").Select
End Function
Give it a shot!