3

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: enter image description here

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

4
  • 1
    How do the values in cell D3 relate the the values in C3? Do all of the rows have the same number of values in columns B and C and do they match up with each other?
    – Comintern
    Commented May 30, 2015 at 16:30
  • 1
    I'll post an answer later. The main idea is that you should Split based on the return character. You will need to loop through all the columns in a row at one time to figure out the maximum number of lines. From there, you create that many rows and move the data in. Split will return an array so you can drop the values into your new rows easily. Then you can check out the question/answer for filling in the remaining blanks.
    – Byron Wall
    Commented May 30, 2015 at 16:59
  • This is also nearly a duplicate of this question. You may find an answer in there.
    – Byron Wall
    Commented May 30, 2015 at 17:01
  • Maybe you can do this straightforward in Excel, without VBA.
    – srodriguex
    Commented Jun 2, 2017 at 14:36

2 Answers 2

5

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.

output of the code

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.
2
  • thank you!! I just started VBA a week ago and knew how I wanted to write this, but was really lost on the language. If I didn't need this for a report due in two days I would have continued to struggle with it till I figured it out. Thanks again!
    – pheeper
    Commented May 31, 2015 at 13:15
  • 1
    For those who have legit blank cells in their initial data, just fill them with a replaceable pattern before applying the macro, and revert afterwards. Saved me so much time !
    – Mat M
    Commented May 2, 2017 at 14:43
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!

4
  • Code is a solid in-place solution to process the data. Two things I don't like though: 1) catching errors to determine if you have enough elements in each array to output. Could just as easily check If TempInt > UBound(Barray) Then : [cell value] = "" : Else : [cell value]=[array value] : End If. 2) using Select to copy/insert/paste is unnecessary; delete the Select Selection. and it will work fine and not rely on the interface. Finally, aren't you glad he didn't need this for 10 columns? :)
    – Byron Wall
    Commented May 31, 2015 at 4:47
  • Also, depending on how OP wants the blank cells dealt with, you may need to throw in the code to fill the blanks. I assumed that OP wanted them filled in since there was a previous question indicating that.... although that question was dropped for this one, so who knows how relevant it is.
    – Byron Wall
    Commented May 31, 2015 at 4:48
  • @Byron excellent points. Thank you for sharing. Indeed, I am glad that OP didn't do this for many columns :)
    – zedfoxus
    Commented May 31, 2015 at 4:59
  • @zedfoxus thanks for the response, however I needed the waterfall part that Byron put in and I needed it to go through column CP so to build this out would be difficult.
    – pheeper
    Commented May 31, 2015 at 13:12

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

Not the answer you're looking for? Browse other questions tagged or ask your own question.