Query on Text to Columns

Try something like:

Sub foo()
Dim stX() As String, stY() As String
Dim x As Integer, y As Integer
Dim lRowSrc As Long, lRowTgt As Long


lRowSrc = 6

With Sheet1
    Do Until .Cells(lRowSrc, 1).Value = ""
        stX = Split(.Cells(lRowSrc, 4).Value, Chr(10))
        lRowTgt = .Cells(Rows.Count, 1).End(xlUp).Row + 1
        For x = LBound(stX) To UBound(stX)
            .Cells(lRowSrc, 1).Resize(1, 4).Copy .Cells(lRowTgt + x, 1)
            stY = Split(stX(x), "^")
            For y = LBound(stY) To UBound(stY)
                .Cells(lRowTgt + x, 5 + y).Value = stY(y)
            Next y
        Next x
        lRowSrc = lRowSrc + 1
    Loop
End With

End Sub

Adjust to suit.

Hi Sats ... a line return within a cell is a character which code is chr(10). So if you write code to run through each row, look at the comments cell and determine whether that character is present, you can split out the text and create duplicate rows with the separate comments. I suggest using the Instr function; if the return value is greater than zero, there are line returns in the cell; if it = zero, there are not. The same approach, looking for the ^ character, can be used to populate the separate columns for each line found. So this will find the three lines (run it in a loop until it = 0):

instr(1,activecell.value,chr(10),vbTextCompare)

and this will find the three values for the columns:

instr(1,activecell.value,"^",vbTextCompare)

XL Split Function.xlsm

I like Olly's solution ... Split function .. nice :-)

One very small addition under the comment:

Sub foo2()
Dim stX() As String, stY() As String
Dim x As Integer, y As Integer
Dim lRowSrc As Long, lRowTgt As Long

lRowSrc = 6

With Sheet1
    Do Until .Cells(lRowSrc, 1).Value = ""
        stX = Split(.Cells(lRowSrc, 4).Value, Chr(10))
        lRowTgt = .Cells(Rows.Count, 1).End(xlUp).Row + 1
        For x = LBound(stX) To UBound(stX)
            .Cells(lRowSrc, 1).Resize(1, 4).Copy .Cells(lRowTgt + x, 1)
            'overwrite new comments cell:
            .Cells(lRowTgt + x, 4) = stX(x)
            stY = Split(stX(x), "^")
            For y = LBound(stY) To UBound(stY)
                .Cells(lRowTgt + x, 5 + y).Value = stY(y)
            Next y
        Next x
        lRowSrc = lRowSrc + 1
    Loop
End With

End Sub

Please give credit to Olly :-)

Glad it does what you wanted - thanks for the feedback. And thanks MatrixMan for uploading a sample workbook - appreciate the help

Something like:

Sub foo3()
Dim stX() As String, stY() As String
Dim x As Integer, y As Integer
Dim lRowSrc As Long, lRowTgt As Long
Dim wsSrc As Worksheet, wsTgt As Worksheet

' Change 'source' and 'target' worksheet names here
Set wsSrc = Worksheets("Sheet1")
Set wsTgt = Worksheets("Sheet2")

' Set start row for source data:
lRowSrc = 6

With wsSrc
    Do Until .Cells(lRowSrc, 1).Value = ""
        stX = Split(.Cells(lRowSrc, 4).Value, Chr(10))
        lRowTgt = wsTgt.Cells(Rows.Count, 1).End(xlUp).Row + 1
        For x = LBound(stX) To UBound(stX)
            wsTgt.Cells(lRowTgt + x, 1).Resize(1, 3).Value = .Cells(lRowSrc, 1).Resize(1, 3).Value
            wsTgt.Cells(lRowTgt + x, 4) = stX(x)
            stY = Split(stX(x), "^")
            For y = LBound(stY) To UBound(stY)
                wsTgt.Cells(lRowTgt + x, 5 + y).Value = stY(y)
            Next y
        Next x
        lRowSrc = lRowSrc + 1
    Loop
End With

End Sub

Change the worksheet names as necessary.

Attach your file.

You haven't changed the worksheet names...

In your workbook, Sheet2 is the source, and Sheet1 is the target...

So swap those names over in the code:

Set wsSrc = Worksheets("Sheet2")
Set wsTgt = Worksheets("Sheet1")