VBA to split multi-line text in a excel cell into separate rows and keeping adjacent cell values

Question

Please see the attach image which shows my data and expected data after running the macro,

• I would like to split the multi line cell in column B and listed in

Answer 1

This code will work on the first example you posted to give the output you wanted:

Original Source:

Original Results:

It works by using Class and Collections, creating each entry one at a time, and then putting it together for the results.

I use arrays to collect and output the data, because this will work much faster. In your original you had some font coloring, which I have carried over.

You should be able to adapt it to your real data, but, if you cannot, I suggest you post a "sanitized" copy of your original data, with the correct columns and so forth, on some file sharing web site such as DropBox, OneDrive, etc; and post a link here so we can see the "real stuff"

With regard to the use of classes, please see Chip Pearson's web site

Also, please read the comments in the code for explanations and suggestions.

First insert a Class Module, ReNAME it cOfcCode and paste the code below into it:

'Will need to add properties for the additional columns

Option Explicit

Private pSEPY As String
Private pFontColor As Long
Private pSESE As String
Private pRule As String

Public Property Get SEPY() As String
    SEPY = pSEPY
End Property
Public Property Let SEPY(Value As String)
    pSEPY = Value
End Property

Public Property Get FontColor() As Long
    FontColor = pFontColor
End Property
Public Property Let FontColor(Value As Long)
    pFontColor = Value
End Property

Public Property Get Rule() As String
    Rule = pRule
End Property
Public Property Let Rule(Value As String)
    pRule = Value
End Property

Public Property Get SESE() As String
    SESE = pSESE
End Property
Public Property Let SESE(Value As String)
    pSESE = Value
End Property

Then, in a regular module:

Option Explicit
Sub ReformatData()
    Dim wsSrc As Worksheet, wsRes As Worksheet
    Dim rSrc As Range, rRes As Range
    Dim vSrc As Variant, vRes As Variant
    Dim vSEPY As Variant, vSESE As Variant
    Dim cOC As cOfcCode
    Dim colOC As Collection
    Dim lRGB As Long
    Dim I As Long, J As Long, K As Long

'Change Sheet references as needed
Set wsSrc = Worksheets("Sheet2")
Set wsRes = Worksheets("Sheet3")

'Assuming Data is in Columns A:C
With wsSrc
    Set rSrc = .Range("A1", .Cells(.Rows.Count, "C").End(xlUp))
End With
Set rRes = wsRes.Range("A1")

vSrc = rSrc
Set colOC = New Collection  'Collection of each "to be" row
For I = 2 To UBound(vSrc, 1)

    'Split SEPY_PFX into relevant parts
    vSEPY = Split(vSrc(I, 1), ",")
    For J = 0 To UBound(vSEPY)

        'Get the font color from the original cell
        With rSrc(I, 1)
            lRGB = .Characters(InStr(1, .Value, vSEPY(J), vbTextCompare), 1).Font.Color
        End With

        'Split SESE_ID into relevant parts
        vSESE = Split(vSrc(I, 2), vbLf)

        'Iterate through each SESE_ID, picking up the SEPY_PFX, and RULE
        For K = 0 To UBound(vSESE)
            Set cOC = New cOfcCode

            'Will need to adjust for the extra columns
            With cOC
                .FontColor = lRGB
                .Rule = vSrc(I, 3)
                .SEPY = vSEPY(J)
                .SESE = vSESE(K)
                colOC.Add cOC '<-- ADD to the collection
            End With
        Next K
    Next J
Next I

'Put together the Results
ReDim vRes(0 To colOC.Count, 1 To UBound(vSrc, 2))

'Copy the column headings from the source
For I = 1 To UBound(vRes, 2)
    vRes(0, I) = vSrc(1, I)
Next I

'Will need to add entries for the other columns
For I = 1 To colOC.Count
    With colOC(I)
        vRes(I, 1) = .SEPY
        vRes(I, 2) = .SESE
        vRes(I, 3) = .Rule
    End With
Next I

'Clear the results worksheet and write the results
wsRes.Cells.Clear
Set rRes = rRes.Resize(UBound(vRes, 1) + 1, UBound(vRes, 2))
rRes = vRes

'Add the correct font color and format
For I = 1 To colOC.Count
    rRes.Rows(I + 1).Font.Color = colOC(I).FontColor
Next I

With rRes.Rows(1)
    .Font.Bold = True
    .HorizontalAlignment = xlCenter
End With

rRes.EntireColumn.AutoFit

End Sub

Make the changes to the Worksheet references in the code (only need to do that at the beginning of the regular module.

Try this first on your original example, so you can see how it works, then add in the extra columns and processing to the Class and the Collection, or post back here with more details

Answer 2

I assume the original data is in worksheet "DATA", and worksheet "Expected Output" which is used to store processed data , exist already.

Your code will be:　Operation of most lines are explained by comments (right of "'")

Sub processData()
Dim oWS As Worksheet, pWS As Worksheet
Dim oRow As Long, pRow As Long
Dim splitMultiLine As String, splitPerfix As String
Dim c As Long, i As Long, j As Long, k As Long
Dim prefixes As Variant, lines As Variant
Dim dataACol As String, dataBCol As String, dataCCol As String


Set oWS = Worksheets("DATA") 'original data
Set pWS = Worksheets("Expected Output") 'processed data

'Copy title row
For c = 1 To 3
  pWS.Cells(1, c) = oWS.Cells(1, c)
Next c

oRow = 2 ' row of oWS
pRow = 2 ' row of pWS

With oWS
  While (.Cells(oRow, 1) <> "") 'Loop while A colmn has value
    dataACol = .Cells(oRow, 1) 'data in A column
    dataBCol = .Cells(oRow, 2) 'data in B column
    dataCCol = .Cells(oRow, 3) 'data in C colum

    prefixes = Split(dataACol, ",") ' split prefixes by comma
    lines = Split(dataBCol, Chr(10)) ' split multi lines in a cell by newline (Char(10))

    For i = LBound(prefixes) To UBound(prefixes)
      For j = LBound(lines) To UBound(lines)
        pWS.Cells(pRow, 1) = Trim(prefixes(i)) ' A column of output
        k = InStr(lines(j), " ")
        pWS.Cells(pRow, 2) = Left(lines(j), k - 1) ' B column of output
        pWS.Cells(pRow, 3) = dataCCol ' C column of output
        pRow = pRow + 1
      Next j
    Next i
    oRow = oRow + 1
  Wend
End With
End Sub