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

C

caleb123

New Member
Joined
Oct 8, 2015
Messages
5
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:

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.

[TABLE="class: grid, width: 500"]
<tbody>[TR]
[TD]ID[/TD]
[TD]Title[/TD]
[TD]Date[/TD]
[TD]Type[/TD]
[TD]Status[/TD]
[TD]Names[/TD]
[TD]Division[/TD]
[TD]Dept[/TD]
[TD]Lead[/TD]
[TD]Dept[/TD]
[/TR]
[TR]
[TD]123[/TD]
[TD]XXX Vaccine[/TD]
[TD]7/18/2008[/TD]
[TD]Other[/TD]
[TD]Active[/TD]
[TD]Oz,Kemp,Brown[/TD]
[TD]Med,Med,Eng[/TD]
[TD]Int Med,Hem Onc,Materials[/TD]
[TD]Kemp[/TD]
[TD]Hem Onc[/TD]
[/TR]
[TR]
[TD]124[/TD]
[TD]DDX5[/TD]
[TD]7/21/2008[/TD]
[TD]Process[/TD]
[TD]Closed[/TD]
[TD]James,Li,Shi,Ge[/TD]
[TD]Med,Med,LSA,Other[/TD]
[TD]Int Med,Int Med,Physics,[/TD]
[TD]James[/TD]
[TD]Int Med[/TD]
[/TR]
[TR]
[TD]125[/TD]
[TD]Nanoemulsion[/TD]
[TD]8/5/2008[/TD]
[TD]Therapeutic[/TD]
[TD]Exclusive[/TD]
[TD]Wang,Sun[/TD]
[TD]Med,Med[/TD]
[TD]Allergy,Allergy[/TD]
[TD]Wang[/TD]
[TD]Allergy[/TD]
[/TR]
</tbody>[/TABLE]

I need the data in the following format:


[TABLE="class: grid, width: 500"]
<tbody>[TR]
[TD]ID[/TD]
[TD]Title[/TD]
[TD]Date[/TD]
[TD]Type[/TD]
[TD]Status[/TD]
[TD]Names[/TD]
[TD]Division[/TD]
[TD]Dept[/TD]
[TD]Lead[/TD]
[TD]Dept[/TD]
[/TR]
[TR]
[TD]123[/TD]
[TD]XXX Vaccine[/TD]
[TD]7/18/2008[/TD]
[TD]Other[/TD]
[TD]Active[/TD]
[TD]Oz[/TD]
[TD]Med[/TD]
[TD]Int Med[/TD]
[TD]Kemp[/TD]
[TD]Hem Onc[/TD]
[/TR]
[TR]
[TD]123[/TD]
[TD]XXX Vaccine[/TD]
[TD]7/18/2008[/TD]
[TD]Other[/TD]
[TD]Active[/TD]
[TD]Kemp[/TD]
[TD]Med[/TD]
[TD]Hem Onc[/TD]
[TD]Kemp[/TD]
[TD]Hem Onc[/TD]
[/TR]
[TR]
[TD]123[/TD]
[TD]XXX Vaccine[/TD]
[TD]7/18/2008[/TD]
[TD]Other[/TD]
[TD]Active[/TD]
[TD]Brown[/TD]
[TD]Eng[/TD]
[TD]Materials[/TD]
[TD]Kemp[/TD]
[TD]Hem Onc[/TD]
[/TR]
[TR]
[TD]124[/TD]
[TD]DDX5[/TD]
[TD]7/21/2008[/TD]
[TD]Process[/TD]
[TD]Closed[/TD]
[TD]James[/TD]
[TD]Med[/TD]
[TD]Int Med[/TD]
[TD]James[/TD]
[TD]Int Med[/TD]
[/TR]
[TR]
[TD]124[/TD]
[TD]DDX5[/TD]
[TD]7/21/2008[/TD]
[TD]Process[/TD]
[TD]Closed[/TD]
[TD]Li[/TD]
[TD]Med[/TD]
[TD]Int Med[/TD]
[TD]James[/TD]
[TD]Int Med[/TD]
[/TR]
[TR]
[TD]124[/TD]
[TD]DDX5[/TD]
[TD]7/21/2008[/TD]
[TD]Process[/TD]
[TD]Closed[/TD]
[TD]Shi[/TD]
[TD]LSA[/TD]
[TD]Physics[/TD]
[TD]James[/TD]
[TD]Int Med[/TD]
[/TR]
[TR]
[TD]124[/TD]
[TD]DDX5[/TD]
[TD]7/21/2008[/TD]
[TD]Process[/TD]
[TD]Closed[/TD]
[TD]Ge[/TD]
[TD]Other[/TD]
[TD][/TD]
[TD]James[/TD]
[TD]Int Med[/TD]
[/TR]
[TR]
[TD]125[/TD]
[TD]Nanoemulsion[/TD]
[TD]8/5/2008[/TD]
[TD]Therapeutic[/TD]
[TD]Exclusive[/TD]
[TD]Wang[/TD]
[TD]Med[/TD]
[TD]Allergy[/TD]
[TD]Wang[/TD]
[TD]Allergy[/TD]
[/TR]
[TR]
[TD]125[/TD]
[TD]Nanoemulsion[/TD]
[TD]8/5/2008[/TD]
[TD]Therapeutic[/TD]
[TD]Exclusive[/TD]
[TD]Sun[/TD]
[TD]Med[/TD]
[TD]Allergy[/TD]
[TD]Wang[/TD]
[TD]Allergy[/TD]
[/TR]
</tbody>[/TABLE]
 

Excel Facts

How to create a cell-sized chart?
Tiny charts, called Sparklines, were added to Excel 2010. Look for Sparklines on the Insert tab.
Sort by date Sort by votes
Are there ever more than 3 or less than 1 commas in a string? (i.e. "Oz,Kemp,Brown,Smith,Jones" or "Williams")
 
Upvote 0
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").

Code: 
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.
 
Upvote 0
Alright, got it.

Code: 
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.
 
Upvote 0
You must log in or register to reply here.

Similar threads

P
  • Solved
Splitting text into columns where text is located across multiple adjacent cells?
Replies
7
Views
1K
Peter_SSs
Peter_SSs
TheMacroNoob
  • Solved
Repeating Rows based on Property IDs and GL Codes
Replies
9
Views
582
Fluff
Fluff
N
  • Question Question
Join data from second worksheet with delimited list values (mults) to another worksheet with one value per cell/row and keep 1:1 relationship
Replies
2
Views
1K
HeadAgainstABrickWall
H
D
  • Question Question
Split delimited data in one cell to multiple rows using macro & apply to whole column
Replies
4
Views
4K
mumps
mumps
O
  • Question Question
(Power?) pivot: filter or split comma separated data in one cell to multiple columns in (power?) pivot table (by measure?)
Replies
0
Views
1K
ooptennoort
O

Forum statistics

Threads
1,223,234
Messages
6,170,891
Members
452,366
Latest member
TePunaBloke

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top