Thread: splitting multile lines in one cell into columns

The contact names appear to be in column K - you can split these type of entries with Chr(10)

Sub spltData()
Dim ws1 As Worksheet, ws2 As Worksheet, k As Long
Set ws1 = Worksheets("Sheet1")
Set ws2 = Worksheets("Sheet2")
Dim spltStr As String, splNew
For k = 2 To ws1.Cells(Rows.Count, "K").End(xlUp).Row
spltStr = ws1.Range("K" & k).Value
splNew = Split(spltStr, Chr(10))
ws2.Range("A" & ws2.Cells(Rows.Count, "A").End(xlUp).Row + 1).Resize(, UBound(splNew)) = splNew
Next
End Sub

See attached workbook

Only other comment here would be that it sometimes depends on how the data is entered in the sheet in the first place; if it is being entered directly then using the split function as Anthony has shown will work fine. But if your data is imported, added via code or otherwise manipulated it can sometimes also have chr(13) characters in it. You could put in another check for chr(13) as shown or you could "manually" check for both like this:

Private Sub ExtractLines()
Dim intLastCol As Integer, intNewLinePosition As Integer, intStart As Integer
Dim lngLastRow As Long, lngRow As Long
Dim strFullText As String, strSingleLine As String

    lngLastRow = Cells(Rows.Count, ActiveCell.Column).End(xlUp).Row
    For lngRow = 1 To lngLastRow
        intColOffset = 0
        intStart = 1
        strFullText = Cells(lngRow, ActiveCell.Column).Text
        intNewLinePosition = InStr(intStart, strFullText, Chr(10), vbTextCompare)
        While intNewLinePosition > 0
            intStart = intNewLinePosition - 1
            strSingleLine = Left(strFullText, intStart)
            If InStr(1, strSingleLine, Chr(13), vbTextCompare) > 0 Then strSingleLine = Left(strFullText, intStart - 1)
            intLastCol = Cells(lngRow, Columns.Count).End(xlToLeft).Column
            Cells(lngRow, intLastCol + 1).Value = strSingleLine
            strFullText = Right(strFullText, Len(strFullText) - intNewLinePosition)
            intNewLinePosition = InStr(intStart, strFullText, Chr(10), vbTextCompare)
            If strFullText <> "" And strFullText <> Chr(10) And strFullText <> Chr(13) And intNewLinePosition = 0 Then Cells(lngRow, intLastCol + 2).Value = strFullText
        Wend
    Next lngRow

End Sub

The above is doing "manually" what the Split function does and checks for both chr(10) and chr(13). To run: paste it into the sheet with your data, select the column you want to split out and it will write the data to the next available column in that row (which means you can select any column and split out whatever is in multiple lines across your sheet).

Hope that helps.