Duplicate rows if cell contains carriage return (or possibly newline)

[matybg]

Hi,

I would like to know how I can duplicate a row if a cell in a particular column has multiple values separated by a carriage return (or maybe its an endline not sure). My data looks something like this:

uniquetext_A text1
text2
uniquetext_B text1
uniquetext_C text1
text2
text3

and the result would ideally be:

uniquetext_A text1
uniquetext_A text2
uniquetext_B text1
uniquetext_C text1
uniquetext_C text2
uniquetext_C text3


I've already tried this:

Sub SplitCarriages() 
    Dim mySplit() As String 
    Dim i As Long, txtCount As Long 
    Dim lastRow As Long, recRow As Long 
    Dim searchCol As String 
    Dim sourceWS As Worksheet, dumpWS As Worksheet 
     
     
     'Which worksheet as we getting data from?
    Set sourceWS = Worksheets("Sheet1") 
     'Which worksheet are we putting data in?
    Set dumpWS = Worksheets("Sheet2") 
     'Which column has carraige returns?
    searchCol = "B" 
     
     
    Application.ScreenUpdating = False 
    dumpWS.Select 
    recRow = 0 
    With sourceWS 
        lastRow = .Cells(.Rows.Count, searchCol).End(xlUp).Row 
         
         'Starting at row 1, presumably
        For i = 1 To lastRow 
            mySplit = Split(.Cells(i, searchCol), Chr(10)) 
            For txtCount = LBound(mySplit) To UBound(mySplit) 
                recRow = recRow + 1 
                 'Copy whole row
                .Cells(i, 1).EntireRow.Copy Cells(recRow, 1) 
                 'Place single line of text
                Cells(recRow, searchCol).Value = mySplit(txtCount) 
            Next txtCount 
        Next i 
    End With 
    Application.ScreenUpdating = True 
     
     
End Sub

And I'm having partial success, with problems though.
Here are my before-after macro pictures of the sheet, and also a link to the original file.

Original: https://drive.google.com/open?id=0B661J_9je5FVRkYyTU9XLV9HQ2M
Post-Macro: https://drive.google.com/open?id=0B661J_9je5FVYWdRY29IWGZxd28

Original File: https://drive.google.com/open?id=0B661J_9je5FVM21raWpuTUI5STA

Regards!

 

[Rick Rothstein]

Give this macro a try (and note there are four Const, short for constants, statements that you can use to adapt to your layout should it be different than what you showed us)...

[TABLE="width: 500"]
<tbody>[TR]
[TD]Sub RedistributeData()
  Dim X As Long, LastRow As Long, A As Range, Table As Range, Data() As String
  Const Delimiter As String = vbLf
  Const DelimitedColumn As String = "D"
  Const TableColumns As String = "A:D"
  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) > 0 Then
      Intersect(Rows(X + 1), Columns(TableColumns)).Resize(UBound(Data)).Insert xlShiftDown
    End If
    If Len(Cells(X, DelimitedColumn)) Then
      Cells(X, DelimitedColumn).Resize(UBound(Data) + 1) = WorksheetFunction.Transpose(Data)
    End If
  Next
  LastRow = Cells(Rows.Count, DelimitedColumn).End(xlUp).Row
  On Error Resume Next
  Set Table = Intersect(Columns(TableColumns), Rows(StartRow).Resize(LastRow - StartRow + 1))
  If Err.Number = 0 Then
    Table.SpecialCells(xlBlanks).FormulaR1C1 = "=R[-1]C"
    Columns(DelimitedColumn).SpecialCells(xlFormulas).Clear
    Table.Value = Table.Value
  End If
  On Error GoTo 0
  Application.ScreenUpdating = True
End Sub
[/TD]
[/TR]
</tbody>[/TABLE]

Note
-------------
This code was taken directly from my mini-blog article here...

<!-- title / author block --> [h=3]Redistribute a Delimited Column Of Data into Separate Rows (Keeping Other Data As Is)[/h]

 

[matybg]

Give this macro a try (and note there are four Const, short for constants, statements that you can use to adapt to your layout should it be different than what you showed us)...

[TABLE="width: 500"]
<tbody>[TR]
[TD]Sub RedistributeData()
  Dim X As Long, LastRow As Long, A As Range, Table As Range, Data() As String
  Const Delimiter As String = vbLf
  Const DelimitedColumn As String = "D"
  Const TableColumns As String = "A:D"
  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) > 0 Then
      Intersect(Rows(X + 1), Columns(TableColumns)).Resize(UBound(Data)).Insert xlShiftDown
    End If
    If Len(Cells(X, DelimitedColumn)) Then
      Cells(X, DelimitedColumn).Resize(UBound(Data) + 1) = WorksheetFunction.Transpose(Data)
    End If
  Next
  LastRow = Cells(Rows.Count, DelimitedColumn).End(xlUp).Row
  On Error Resume Next
  Set Table = Intersect(Columns(TableColumns), Rows(StartRow).Resize(LastRow - StartRow + 1))
  If Err.Number = 0 Then
    Table.SpecialCells(xlBlanks).FormulaR1C1 = "=R[-1]C"
    Columns(DelimitedColumn).SpecialCells(xlFormulas).Clear
    Table.Value = Table.Value
  End If
  On Error GoTo 0
  Application.ScreenUpdating = True
End Sub[/TD]
[/TR]
</tbody>[/TABLE]

Note
-------------
This code was taken directly from my mini-blog article here...

<!-- title / author block --> Redistribute a Delimited Column Of Data into Separate Rows (Keeping Other Data As Is)

It works wonders!! Thanks a lot Rick!!!!