Convert Cell w/ Manual Breaks into New Rows

[hr38581]

I am attempting to develop a macro that creates a worksheet and pastes into
it a range of data (2 columns) from another worksheet in the same workbook.
(I’ve got that much working so far in my macro. Now for the part I haven’t
been able to figure out…) Column A will have some cells that contain manual
line breaks in between the data items in that cell. The cells in Column B
will only contain a single data item. The single data item in Column B needs
to be associated with each of the data items in Column A, same row. So I
need each cell (in Column A) that contains manual line break(s) to be broken
into multiple rows and the value in the same row Column B repeated in each
new row. (The columns will always be 2, but the rows will vary each time the
macro is run.)
Example:
Start with this:
Col A Col B
Row1 data1.1 X
Row2 data2.1 Y
data2.2
data2.3
Row3 data3.1 Z
data3.2
Change it to this:
Col A Col B
Row1 data1.1 X
Row2 data2.1 Y
Row3 data2.2 Y
Row4 data2.3 Y
Row5 data3.1 Z
Row6 data3.2 Z

What code can make this happen?

 

[dmoney]

Sub tst()
Range("b1").Select
LastRow = Cells(Rows.Count, "b").End(xlUp).Row
Do Until LastRow = ActiveCell.Row
If ActiveCell.Value <> "" Then
Dim a As String
a = ActiveCell.Address
ActiveCell.Offset(1, 0).Activate
Count = 1
End If
Do Until ActiveCell.Value <> ""
If ActiveCell.Value = "" Then
ActiveCell.Offset(1, 0).Activate
Count = Count + 1
End If
Loop
Dim b As String
ActiveCell.Offset(-1, 0).Activate
b = ActiveCell.Address
Range(a & ":" & b).FillDown
ActiveCell.Offset(1, 0).Activate
Loop
'
End Sub

 

[TomPl]

This code assumes that the active cell is the first data cell in column A. I
think it will do what you asked by inserting a row after each cell with a
hard return and copying the appropriate data.

Sub DoFunnyThings()

Dim rngCell As Range

Set rngCell = ActiveCell

Do Until IsEmpty(rngCell)
If InStr(rngCell, Chr(10)) > 0 Then
rngCell.Offset(1, 0).EntireRow.Insert
rngCell.Offset(1, 0).Value = Mid(rngCell, InStr(rngCell, Chr(10)) + 1,
256)
rngCell.Offset(1, 1).Value = rngCell.Offset(0, 1).Value
rngCell.Value = Left(rngCell, InStr(rngCell, Chr(10)) - 1)
End If
Set rngCell = rngCell.Offset(1, 0)
Loop

End Sub

 

[hr38581]

Thank you very much, but unfortunately that copied the contents of cell B1
and pasted it into all the cells of column B (except for the last used cell).
It did not seem to add any new rows as needed either. Any other ideas?

 

[hr38581]

That worked perfectly! Thank you so very much!