Splitting single rows containing delimited data into multiple rows when delimited data across columns is linked

[caleb123]

Here's the problem:

I have a large spreadsheet filled with data across columns A:J. Each cell in each column contains a single value, EXCEPT columns F:H, which contain delimited data. I need to split these cells into multiple rows so that each row in the spreadsheet is unique and each cell has a single value.

I found the following thread, which got me most of the way: http://www.mrexcel.com/forum/excel-...ting-single-rows-data-into-multiple-rows.html

Specifically, this bit of code:

Sub RedistributeData()  Dim X As Long, LastRow As Long, A As Range, Table As Range, Cell As Range, Data() As String
  Const Delimiter As String = ","
  Const DelimitedColumn As String = "F"
  Const TableColumns As String = "A:J"
  Const StartRow As Long = 2
  Application.ScreenUpdating = False
  LastRow = Columns(TableColumns).Find(What:="*", SearchOrder:=xlRows, _
            SearchDirection:=xlPrevious, LookIn:=xlFormulas).Row
  For X = LastRow To StartRow Step -1
    Data = Split(Cells(X, DelimitedColumn), Delimiter)
    If UBound(Data) Then
      Intersect(Rows(X + 1), Columns(TableColumns)).Resize(UBound(Data)).Insert xlShiftDown
    End If
    Cells(X, DelimitedColumn).Resize(UBound(Data) + 1) = WorksheetFunction.Transpose(Data)
  Next
  LastRow = Cells(Rows.Count, DelimitedColumn).End(xlUp).Row
  On Error GoTo NoBlanks
  Set Table = Intersect(Columns(TableColumns), Rows(StartRow).Resize(LastRow - StartRow + 1))
  On Error GoTo 0
  For Each A In Table.SpecialCells(xlBlanks).Areas
    A.FormulaR1C1 = "=R[-1]C"
    A.Value = A.Value
  Next
NoBlanks:
  Application.ScreenUpdating = True
End Sub

The problem with this code is that it splits columns one at a time. In my specific case, the columns containing delimited data have it in a specific order. For example, the first item in column F should pair with the first item in column G, which should pair with the first item in column H. Below is example data.

ID	Title	Date	Type	Status	Names	Division	Dept	Lead	Dept
123	XXX Vaccine	7/18/2008	Other	Active	Oz,Kemp,Brown	Med,Med,Eng	Int Med,Hem Onc,Materials	Kemp	Hem Onc
124	DDX5	7/21/2008	Process	Closed	James,Li,Shi,Ge	Med,Med,LSA,Other	Int Med,Int Med,Physics,	James	Int Med
125	Nanoemulsion	8/5/2008	Therapeutic	Exclusive	Wang,Sun	Med,Med	Allergy,Allergy	Wang	Allergy

<tbody>
</tbody>

I need the data in the following format:

ID	Title	Date	Type	Status	Names	Division	Dept	Lead	Dept
123	XXX Vaccine	7/18/2008	Other	Active	Oz	Med	Int Med	Kemp	Hem Onc
123	XXX Vaccine	7/18/2008	Other	Active	Kemp	Med	Hem Onc	Kemp	Hem Onc
123	XXX Vaccine	7/18/2008	Other	Active	Brown	Eng	Materials	Kemp	Hem Onc
124	DDX5	7/21/2008	Process	Closed	James	Med	Int Med	James	Int Med
124	DDX5	7/21/2008	Process	Closed	Li	Med	Int Med	James	Int Med
124	DDX5	7/21/2008	Process	Closed	Shi	LSA	Physics	James	Int Med
124	DDX5	7/21/2008	Process	Closed	Ge	Other		James	Int Med
125	Nanoemulsion	8/5/2008	Therapeutic	Exclusive	Wang	Med	Allergy	Wang	Allergy
125	Nanoemulsion	8/5/2008	Therapeutic	Exclusive	Sun	Med	Allergy	Wang	Allergy

<tbody>
</tbody>

 

[svendiamond]

Are there ever more than 3 or less than 1 commas in a string? (i.e. "Oz,Kemp,Brown,Smith,Jones" or "Williams")

 

[svendiamond]

This code will copy the row (from "Sheet1") the correct amount of times based on how many commas are in field F (Names) -- so the first one "Oz,Kemp,Brown" will become three rows (on "Sheet2").

Sub reOrganized()


Dim commasFound As Integer, lastRow As Long, firstBlank As Long
Dim searchRange As Range, searchCell As Range
Dim ws1 As Worksheet, ws2 As Worksheet
Dim a As Integer, b As Integer
Dim my_txt As String

Set ws1 = Sheets("Sheet1")
Set ws2 = Sheets("Sheet2")

    ws2.Range("A2:J100").ClearContents
    lastRow = ws1.Range("A" & Rows.Count).End(xlUp).Row

'look for commas in range F
Set searchRange = ws1.Range("F2:F" & lastRow)
    For Each searchCell In searchRange
        a = Len(searchCell)
        my_txt = Replace(searchCell, ",", "", 1, -1, vbTextCompare)
        b = Len(my_txt)
        commasFound = a - b
        
        'this part copies it
        firstBlank = ws2.Range("A" & Rows.Count).End(xlUp).Row + 1
        ws1.Rows(searchCell.Row).Copy _
            ws2.Range("A" & firstBlank & ":A" & firstBlank + commasFound)
            
    Next searchCell
End Sub

I am in the middle of trying to figure out how to copy the values automatically and haven't found the best way yet, but I figured I'd leave you with this for now. If the data is so large you can't manually do that part, let me know and I will come up with a solution.

 

[svendiamond]

Alright, got it.

Sub reOrganize()


Dim commasFound As Integer, lastRow As Long, firstBlank As Long
Dim searchRange As Range, searchCell As Range, foundValue As Variant
Dim ws1 As Worksheet, ws2 As Worksheet
Dim a As Integer, b As Integer
Dim my_txt As String
Set ws1 = Sheets("Sheet1")
Set ws2 = Sheets("Sheet2")
    
    ws2.Activate
    ws2.Range("A2:J100").ClearContents
    lastRow = ws1.Range("A" & Rows.Count).End(xlUp).Row
    ws1.Activate
    
Set searchRange = ws1.Range(Cells(2, 6), Cells(lastRow, 6))
    ws2.Activate
    'loop that copy and pastes
    For Each searchCell In searchRange
        a = Len(searchCell)
        my_txt = Replace(searchCell, ",", "", 1, -1, vbTextCompare)
        b = Len(my_txt)
        commasFound = a - b
        firstBlank = ws2.Range("A" & Rows.Count).End(xlUp).Row + 1
        ws1.Rows(searchCell.Row).Copy _
            ws2.Range("A" & firstBlank & ":A" & firstBlank + commasFound)
    Next searchCell




'loop that separates names
For colCount = 6 To 7
ws1.Activate


    Set searchRange = ws1.Range(Cells(2, colCount), Cells(lastRow, colCount))


ws2.Activate
    'major loop
    For Each searchCell In searchRange
        a = Len(searchCell)
        my_txt = Replace(searchCell, ",", "", 1, -1, vbTextCompare)
        b = Len(my_txt)
        commasFound = a - b


                'changes
                myValue = searchCell.Value


                        Select Case commasFound
                            Case Is = 1
                                firComma = WorksheetFunction.Find(",", myValue)
                                firValue = Left(myValue, firComma - 1)
                                secValue = Mid(myValue, firComma + 1, Len(myValue) - firComma)


                                Set foundValue = Columns(colCount).Find(myValue)
                                    foundValue.Offset(0).Value = firValue
                                    foundValue.Offset(1).Value = secValue


                            Case Is = 2
                                firComma = WorksheetFunction.Find(",", myValue)
                                firValue = Left(myValue, firComma - 1)
                                secComma = WorksheetFunction.Find(",", myValue, firComma + 1)
                                secValue = Mid(myValue, firComma + 1, secComma - firComma - 1)
                                thrValue = Mid(myValue, secComma + 1, Len(myValue) - secComma)
                                
                                Set foundValue = Columns(colCount).Find(myValue)
                                    foundValue.Offset(0).Value = firValue
                                    foundValue.Offset(1).Value = secValue
                                    foundValue.Offset(2).Value = thrValue
                                        
                            Case Is = 3
                                firComma = WorksheetFunction.Find(",", myValue)
                                firValue = Left(myValue, firComma - 1)
                                secComma = WorksheetFunction.Find(",", myValue, firComma + 1)
                                secValue = Mid(myValue, firComma + 1, secComma - firComma - 1)
                                thrComma = WorksheetFunction.Find(",", myValue, secComma + 1)
                                thrValue = Mid(myValue, secComma + 1, thrComma - secComma - 1)
                                frtValue = Mid(myValue, thrComma + 1, Len(myValue) - thrComma)


                                Set foundValue = Columns(colCount).Find(myValue)
                                    foundValue.Offset(0).Value = firValue
                                    foundValue.Offset(1).Value = secValue
                                    foundValue.Offset(2).Value = thrValue
                                    foundValue.Offset(3).Value = frtValue
                        End Select
                        
    Next searchCell
Next colCount


End Sub

Granted it is a large amount of code, I think it does the job. Just make sure to adjust the sheet names "Sheet1" and "Sheet2" to whichever sheet your data is on and the new one you want.

 

[caleb123]

Fantastic! Thanks, Sven. This is just what I need.

 

[svendiamond]

Glad I could help!