separating values in comma delimited cells

**JChandler22** · 11-19-2008, 08:30 PM

Hi all,

I have many rows, each of which has a cell with a list of names, each separated by comma. I want to create a separate row for EACH name that is in each cell. For example:

Before:

Col A | Col B
Green | Joe,Bob,Alex
Blue | Joe,Bob
Red | Bob,Alex

After:

Col A | Col B
Green | Joe
Green | Bob
Green | Alex
Blue | Joe
Blue | Bob
Red | Bob
Red | Alex

I've managed to create a macro which will copy a row the appropriate number of times based on the number of names that appear, but I need a bit of help with the next part, which is transposing the names down those columns. I'd rather not use the transpose excel feature, simply because I have so many entries and I'm sure I would make an error somewhere along the way.

Any suggestions are greatly appreciated. Thanks,
J

**stanleydgromjr** · 11-19-2008, 09:51 PM

JChandler22,

Please post a copy of your workbook - see "Manage Attachments".

Have a great day,
Stan

**Kenneth Hobson** · 11-19-2008, 10:13 PM

Insert the first part into a Module to speed things along.

Option Explicit
Public glb_origCalculationMode As Integer

Sub SpeedOn(Optional StatusBarMsg As String = "Running macro...")
  glb_origCalculationMode = Application.Calculation
  With Application
    .Calculation = xlCalculationManual
    .ScreenUpdating = False
    .EnableEvents = False
    .DisplayAlerts = False
    .Cursor = xlWait
    .StatusBar = StatusBarMsg
    .EnableCancelKey = xlErrorHandler
  End With
End Sub

Sub SpeedOff()
  With Application
    .Calculation = glb_origCalculationMode
    .ScreenUpdating = True
    .EnableEvents = True
    .DisplayAlerts = True
    .CalculateBeforeSave = True
    .Cursor = xlDefault
    .StatusBar = False
    .EnableCancelKey = xlInterrupt
  End With
End Sub

Add the next part to another module. The first sub below clears A and B columns and inserts some test data. The last sub does the work using the speed routines above.

Option Explicit

Sub DummyFill()
  [A:B].ClearContents
  [A1] = "Green"
  [B1] = "Joe,Bob,Alex"
  [A2] = "Blue"
  [B2] = "Joe,Bob"
  [A3] = "Red"
  [B3] = "Bob,Alex"
End Sub

Sub ParseColB()
  Dim r As Range, cc As Range
  Dim aVal As Variant, b() As String
  Dim lc As Long, ic As Long, ac As Integer, ub As Integer
  
  SpeedOn
  On Error GoTo EndNow
  
  Set r = Range("A1", Cells(Rows.Count, "A").End(xlUp))
  For lc = r.Count To 1 Step -1
    Set cc = Cells(lc, "A")
    cc.Select
    aVal = cc.Value
    b() = Split(Cells(lc, "B"), ",")
    ub = UBound(b)
    If ub = 0 Then Exit For
    Cells(lc, "B").Value = b(0)
    For ic = 1 To ub
      ActiveCell.EntireRow.Insert
      ActiveCell.Value = aVal
      ActiveCell.Offset(0, 1).Value = b(ic)
    Next ic
  Next lc
  
EndNow:
  SpeedOff
End Sub

Of course there are other ways to do this.

**stanleydgromjr** · 11-20-2008, 09:44 AM

JChandler22,

Your original data is on sheet1, and the resulting data is on sheet2.

Please TEST this FIRST in a COPY of your workbook (always make a backup copy before trying new code, you never know what you might lose).

Press and hold down the 'ALT' key, and press the 'F11' key.

Insert a Module in your VBAProject, Microsoft Excel Objects

Copy the below code, and paste it into the Module1.


Option Explicit
Sub AdjustData()
    Dim LR&, LR2&, Ctr&, Ctr2&, MaxCol&
    Application.ScreenUpdating = False
    With Sheets("Sheet1")
        LR& = Cells(Rows.Count, "A").End(xlUp).Row
        With .Range("C1:C" & LR&)
            .FormulaR1C1 = "=LEN(RC[-1])-LEN(SUBSTITUTE(RC[-1],"","","""")) + 1"
            .Value = .Value
        End With
        .Range("B1:B" & LR&).Copy .Range("D1")
        With .Range("D1:D" & LR&)
            .TextToColumns Destination:=Range("D1"), DataType:=xlDelimited, _
                TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
                Semicolon:=False, Comma:=True, Space:=False, Other:=False, FieldInfo _
                :=Array(Array(1, 1), Array(2, 1), Array(3, 1)), TrailingMinusNumbers:=True
        End With
        LR2& = 1
        MaxCol& = 0
        For Ctr& = 1 To LR& Step 1
            Ctr2& = Range("C" & Ctr&).Value
            If Ctr2& > MaxCol& Then MaxCol& = Ctr2&
            .Range("A" & Ctr&).Copy Sheets("Sheet2").Range("A" & LR2& & ":A" & LR2& + Ctr2& - 1)
            .Range(Cells(Ctr&, 4), Cells(Ctr&, 4 + Ctr2& - 1)).Copy
            With Sheets("Sheet2").Range("B" & LR2&)
                .PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
                Application.CutCopyMode = False
            End With
            LR2& = Sheets("Sheet2").Cells(Rows.Count, "A").End(xlUp).Row + 1
        Next Ctr&
        Range(Cells(1, 3), Cells(LR&, 3 + MaxCol&)).ClearContents
    End With
    Sheets("Sheet2").Select
    Range("C1").Select
    Application.ScreenUpdating = True
End Sub

Then run the "AdjustData" macro.

Have a great day,
Stan

**JChandler22** · 11-20-2008, 10:20 AM

Hi Stanley,

Thanks very much for this useful code. Tried it out and it did exactly what I wanted it to do according to the example I gave. Of course, the data in my actual workbook is a bit more complicated and not so cut-and-dry.

I've attached a mock version here - fake data but same number of columns (though fewer rows than actual), and truer to how my actual data looks. I'm concerned with column N ("Assigned Resources"), and would like to split each row up according to how many names appear in that column. If a row has either one or zero names, it only needs one row and does not need to be split at all.

The macro I have already built looks at the number in column A (which detects how many commas are in column N) and pastes that many rows... pretty simple macro and I'm sure you'll be able to see what I'm doing there:

Sub addRow2()
Application.ScreenUpdating = False
Dim j As Integer
Range("A2").Activate

For k = 1 To 261
    j = ActiveCell.Value
    For i = 1 To j
        ActiveCell.EntireRow.Select
        Selection.Copy
        ActiveCell.Offset(1, 13).EntireRow.Select
        Selection.Insert Shift:=xlDown
    Next
    ActiveCell.Offset(1, 0).Select
Next
Application.ScreenUpdating = True
End Sub

I hope this helps and that you might be able to give me a quick fix according to this workbook I've attached. Again, thank you VERY much for your willingness to help!

J

**stanleydgromjr** · 11-20-2008, 06:31 PM

JChandler22

See the attached workbook "AdjustData Macro Test - JChandler22 - SDG.xls".

The macro will add a new worksheet "ProjectTasks(2)" with the adjusted data.

Have a great day,
Stan