Creating Duplicate Rows

[tryingmybest418]

Hi all,

I have a worksheet where each row represents a location. Column C lists all of the employees at that location separated by carriage returns.

Is it possible for the sheet to split out the employees and display individual lines for each employee?

[TABLE="class: grid, width: 500"]
<tbody>[TR]
[TD]Location ID[/TD]
[TD]Location[/TD]
[TD]Employees[/TD]
[TD]Manager[/TD]
[TD]Budget[/TD]
[/TR]
[TR]
[TD]100[/TD]
[TD]Chicago[/TD]
[TD]Alex Anderson

Bob Barney

Chris Conners
[/TD]
[TD]Mr. Manager[/TD]
[TD]200,000[/TD]
[/TR]
[TR]
[TD]200[/TD]
[TD]Atlanta[/TD]
[TD]Dan Davidson

Emmit Erickson

Fran Fredrickson[/TD]
[TD]Ms. Supervisor[/TD]
[TD]300,000[/TD]
[/TR]
</tbody>[/TABLE]


[TABLE="class: grid, width: 500"]
<tbody>[TR]
[TD]Location ID[/TD]
[TD]Location[/TD]
[TD]Employee[/TD]
[TD]Manager[/TD]
[TD]Budget[/TD]
[/TR]
[TR]
[TD]100
[/TD]
[TD]Chicago[/TD]
[TD]Alex Anderson[/TD]
[TD]Mr. Manager[/TD]
[TD]200,000[/TD]
[/TR]
[TR]
[TD]100[/TD]
[TD]Chicago[/TD]
[TD]Bob Barney[/TD]
[TD]Mr. Manager[/TD]
[TD]200,000[/TD]
[/TR]
[TR]
[TD]100[/TD]
[TD]Chicago[/TD]
[TD]Chris Conners[/TD]
[TD]Mr. Manager[/TD]
[TD]200,000[/TD]
[/TR]
[TR]
[TD]200[/TD]
[TD]Atlanta[/TD]
[TD]Dan Davidson[/TD]
[TD]Ms. Supervisor[/TD]
[TD]300,000[/TD]
[/TR]
[TR]
[TD]200[/TD]
[TD]Atlanta[/TD]
[TD]Emmit Erickson[/TD]
[TD]Ms. Supervisor[/TD]
[TD]300,000[/TD]
[/TR]
[TR]
[TD]200[/TD]
[TD]Atlanta[/TD]
[TD]Fran Fredrickson[/TD]
[TD]Ms. Supervisor[/TD]
[TD]300,000[/TD]
[/TR]
</tbody>[/TABLE]

Thanks!

 

[footoo]

Sub Split_Cr()
Dim rng As Range, cel As Range, cr%
Set rng = Range([C2], Cells(Rows.Count, "C").End(xlUp))
For Each cel In rng
    cr = Len(cel) - Len(Replace(cel, vbLf, ""))
    If cr > 0 Then
        cel(2).Resize(cr).EntireRow.Insert
        cel.Resize(cr + 1) = WorksheetFunction.Transpose(Split(cel, vbLf))
    End If
Next
Set rng = Range([A2], Cells(Rows.Count, "C").End(xlUp)(1, 3))
rng.SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=R[-1]C"
rng = rng.Value
End Sub

 

[tryingmybest418]

This is great, thank you.

I made a couple adjustments, and it's working better, but there's still an issue:

My worksheet isn't exactly like the example, I have columns through J, so I changed the Set rng line to (1, 8)

I also moved the entire rng portion inside the If statement.

It seems to be close, but i'm getting duplicates- see my new code and example below:

[TABLE="class: cms_table_grid, width: 500"]
<tbody>[TR]
[TD]Location ID[/TD]
[TD]Location[/TD]
[TD]Employees[/TD]
[TD]Manager[/TD]
[TD]Budget[/TD]
[/TR]
[TR]
[TD]100[/TD]
[TD]Chicago[/TD]
[TD]Alex Anderson

Bob Barney

Chris Conners[/TD]
[TD]Mr. Manager[/TD]
[TD]200,000[/TD]
[/TR]
[TR]
[TD]200[/TD]
[TD]Atlanta[/TD]
[TD]Dan Davidson

Emmit Erickson

Fran Fredrickson[/TD]
[TD]Ms. Supervisor[/TD]
[TD]300,000[/TD]
[/TR]
</tbody>[/TABLE]



[TABLE="class: cms_table_grid, width: 500"]
<tbody>[TR]
[TD]Location ID[/TD]
[TD]Location[/TD]
[TD]Employee[/TD]
[TD]Manager[/TD]
[TD]Budget[/TD]
[/TR]
[TR]
[TD]100[/TD]
[TD]Chicago[/TD]
[TD]Alex Anderson[/TD]
[TD]Mr. Manager[/TD]
[TD]200,000[/TD]
[/TR]
[TR]
[TD]100[/TD]
[TD]Chicago[/TD]
[TD]Alex Anderson[/TD]
[TD]Mr. Manager[/TD]
[TD]200,000[/TD]
[/TR]
[TR]
[TD]100[/TD]
[TD]Chicago[/TD]
[TD]Bob Barney
[/TD]
[TD]Mr. Manager[/TD]
[TD]200,000[/TD]
[/TR]
[TR]
[TD]100[/TD]
[TD]Chicago[/TD]
[TD]Bob Barney[/TD]
[TD]Mr. Manager[/TD]
[TD]200,000[/TD]
[/TR]
[TR]
[TD]100[/TD]
[TD]Chicago[/TD]
[TD]Chris Conners[/TD]
[TD]Mr. Manager[/TD]
[TD]200,000[/TD]
[/TR]
[TR]
[TD]100[/TD]
[TD]Chicago[/TD]
[TD]Chris Conners[/TD]
[TD]Mr. Manager[/TD]
[TD]200,000[/TD]
[/TR]
</tbody>[/TABLE]

[TABLE="class: cms_table_grid, width: 500"]
<tbody>[TR]
[TD]200[/TD]
[TD]Atlanta[/TD]
[TD]Dan Davidson[/TD]
[TD]Ms. Supervisor[/TD]
[TD]300,000[/TD]
[/TR]
</tbody>[/TABLE]

[TABLE="class: cms_table_grid, width: 500"]
<tbody>[TR]
[TD]200[/TD]
[TD]Atlanta[/TD]
[TD]Dan Davidson[/TD]
[TD]Ms. Supervisor[/TD]
[TD]300,000[/TD]
[/TR]
</tbody>[/TABLE]


etc.

Sub Split_Cr()
Dim rng As Range, cel As Range, cr%
Set rng = Range([C2], Cells(Rows.Count, "C").End(xlUp))
For Each cel In rng
    cr = Len(cel) - Len(Replace(cel, vbLf, ""))
    If cr > 0 Then
        cel(2).Resize(cr).EntireRow.Insert
        cel.Resize(cr + 1) = WorksheetFunction.Transpose(Split(cel, vbLf))
    
    Set rng = Range([A2], Cells(Rows.Count, "C").End(xlUp)(1, 8))
rng.SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=R[-1]C"
rng = rng.Value
    
    End If


Next


End Sub

Sub Split_Cr()
Dim rng As Range, cel As Range, cr%
Set rng = Range([C2], Cells(Rows.Count, "C").End(xlUp))
For Each cel In rng
    cr = Len(cel) - Len(Replace(cel, vbLf, ""))
    If cr > 0 Then
        cel(2).Resize(cr).EntireRow.Insert
        cel.Resize(cr + 1) = WorksheetFunction.Transpose(Split(cel, vbLf))
    End If
Next
Set rng = Range([A2], Cells(Rows.Count, "C").End(xlUp)(1, 3))
rng.SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=R[-1]C"
rng = rng.Value
End Sub

 

[footoo]

Don't do this : "I also moved the entire rng portion inside the If statement."

Sub Split_Cr()
Dim rng As Range, cel As Range, cr%
Set rng = Range([C2], Cells(Rows.Count, "C").End(xlUp))
For Each cel In rng
    cr = Len(cel) - Len(Replace(cel, vbLf, ""))
    If cr > 0 Then
        cel(2).Resize(cr).EntireRow.Insert
        cel.Resize(cr + 1) = WorksheetFunction.Transpose(Split(cel, vbLf))
    End If
Next
Set rng = Range([A2], Cells(Rows.Count, "C").End(xlUp)(1, [COLOR=#ff0000]8[/COLOR]))
rng.SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=R[-1]C"
rng = rng.Value
End Sub