How to split cells containing multiple values (comma delimited) into separate rows?

Question

I am working with a sample of data that I'd like to split into several rows based on a comma delimiter. My data table in Excel prior to the split looks like this:

This is what the table looks like before the desired transformation

I would like develop VBA code to split values in Column C ('Company Point of Contact') and create separate lines for each 'Company Point of Contact'.

So far I have managed to split the values in Column C into separate lines. However I have not managed to split values in Columns D (Length of Relationship) and E (Strength of Relationship) as well, so that each value separated by a comma corresponds to its respective contact in Column C.

Finally I'd like my table to look like this

You will find below a sample of the code I borrowed to split my cells. The limitation with this code was that it didn't split the other columns in my table, just the one.

How can I make this code work to split the values in the other columns?

Sub Splt()
    Dim LR As Long, i As Long
    Dim X As Variant
    Application.ScreenUpdating = False
    LR = Range("A" & Rows.Count).End(xlUp).Row
    Columns("A").Insert
    For i = LR To 1 Step -1
        With Range("B" & i)
            If InStr(.Value, ",") = 0 Then
                .Offset(, -1).Value = .Value
            Else
                X = Split(.Value, ",")
                .Offset(1).Resize(UBound(X)).EntireRow.Insert
                .Offset(, -1).Resize(UBound(X) - LBound(X) + 1).Value = Application.Transpose(X)
            End If
        End With
    Next i
    Columns("B").Delete
    LR = Range("A" & Rows.Count).End(xlUp).Row
    With Range("B1:C" & LR)
        On Error Resume Next
            .SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=R[-1]C"
         On Error GoTo 0
         .Value = .Value
    End With

    Application.ScreenUpdating = True
End Sub

trincot · Accepted Answer

You should not only iterate the rows, but also the columns, and check in each cell whether there is such a comma. When at least one of the cells in a row has a comma, it should be split.

You could then insert the row, and copy the parts before the comma in the newly created row, while removing that part from the original row which is then moved up one index.

You should also take care to increase the number of rows to traverse whenever you insert a row, or else you will do an incomplete job.

Here is code you could use:

Sub Splt()
    Dim LR As Long, LC As Long, r As Long, c As Long, pos As Long
    Dim v As Variant

    Application.ScreenUpdating = False
    LR = Cells(Rows.Count, 1).End(xlUp).Row
    LC = Cells(1, Columns.Count).End(xlToLeft).Column
    r = 2
    Do While r <= LR
        For c = 1 To LC
            v = Cells(r, c).Value
            If InStr(v, ",") Then Exit For ' we need to split
        Next
        If c <= LC Then ' We need to split
            Rows(r).EntireRow.Insert
            LR = LR + 1
            For c = 1 To LC
                v = Cells(r + 1, c).Value
                pos = InStr(v, ",")
                If pos Then
                    Cells(r, c).Value = Left(v, pos - 1)
                    Cells(r + 1, c).Value = Trim(Mid(v, pos + 1))
                Else
                    Cells(r, c).Value = v
                End If
            Next
        End If
        r = r + 1
    Loop
    Application.ScreenUpdating = True
End Sub

How to split cells containing multiple values (comma delimited) into separate rows?

Answers (2)

Class Module 1

Class Module 2

Regular Module

Related Questions