Split lines in cell into rows while retaining font color in the new rows

[Subash_G]

Our requirement: I have 3 columns in my excel sheet. The 3rd column has data in multiple lines. Each line data in 3rd column cell has either in Green font color or in Black font color. I need to split these lines in 3rd column cell into rows. For example. if there are 3 lines in 3rd column cell, there should be 3 rows created 1 row per 1 line data while 1st 2 columns data should be same as the original data. Appreciate if you could look into this and share a solution on how to split lines in cell into rows without disturbing the format of the cell either by using VBA or any excel formula.

 

[Sam_D_Ben]

May you can try this,

Book1
	A	B	C
1	Column1	Column2	Column3
2	CellsA2	CellsB2	Text1 Text2 Text3
3	CellsA3	CellsB3	Text1 Text2 Text3
4	CellsA4	CellsB4	Text1 Text2 Text3
5	CellsA5	CellsB5	Text1 Text2 Text3
6	CellsA6	CellsB6	Text1 Text2 Text3
7	CellsA4	CellsB4	Text1 Text2 Text3
8	CellsA5	CellsB5	Text1 Text2 Text3
9	CellsA6	CellsB6	Text1 Text2 Text3
Sheet1

Sub SplitLinesIntoRowsWithColorAndHeaders()
    Dim ws As Worksheet, lastRow As Long, i As Long, j As Long, newRowIndex As Long
    Dim lines As Variant
    Set ws = ThisWorkbook.Sheets("Sheet1")
    
    lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
    newRowIndex = lastRow + 2
    
    ws.Rows(newRowIndex).Value = ws.Rows(1).Value: ws.Rows(newRowIndex).Font.Color = ws.Rows(1).Font.Color
    newRowIndex = newRowIndex + 1
    
    For i = 2 To lastRow
        lines = Split(ws.Cells(i, 3).Value, vbLf)
        For j = 0 To UBound(lines)
            If j > 0 Then ws.Rows(newRowIndex + j).Insert Shift:=xlDown
            ws.Cells(newRowIndex + j, 1).Resize(1, 2).Value = ws.Cells(i, 1).Resize(1, 2).Value
            ws.Cells(newRowIndex + j, 3).Value = lines(j)
            ws.Cells(newRowIndex + j, 3).Font.Color = ws.Cells(i, 3).Font.Color
        Next j
        newRowIndex = newRowIndex + UBound(lines) + 1
    Next i
End Sub

 

[Subash_G]

Sam,
Thank you very much for taking time out and providing the solution!

While it is working fine if all the lines in a cell are Green in color OR if all the lines in a cell or Black in color (in fact, it is automatic color but appears to be Black color. We have no issue even if the resulting rows for the lines in automatic color are in black color).

Now, the issue is with when some cells contain lines in both Green/Black color.
For example, if a cell is having 4 lines, then 2 lines could be Green in color and the rest 2 lines could be Black in color. This case is not working as expected and with the code you provided, it is putting all the lines in Black color in the resulting rows for the above example input.

Request you to please take some time out again and provide the modified solution for this updated requirement.
My apologies for not clearly specifying my requirement in the beginning!

Thank you again for all your help!

Thanks,
Subash.

 

[Sam_D_Ben]

May be this,

Sub SplitLinesIntoRowsWithColorAndHeaders()
    Dim ws As Worksheet, lastRow As Long, i As Long, j As Long, newRowIndex As Long, lines As Variant
    Dim srcCell As Range, destCell As Range, charIndex As Long, lineStart As Long
    
    Set ws = ThisWorkbook.Sheets("Sheet1")
    lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
    newRowIndex = lastRow + 2
    ws.Rows(newRowIndex).Value = ws.Rows(1).Value
    ws.Rows(newRowIndex).Font.Color = ws.Rows(1).Font.Color
    newRowIndex = newRowIndex + 1
    
    For i = 2 To lastRow
        Set srcCell = ws.Cells(i, 3)
        lines = Split(srcCell.Value, vbLf)
        
        For j = 0 To UBound(lines)
            If j > 0 Then ws.Rows(newRowIndex + j).Insert xlDown
            ws.Cells(newRowIndex + j, 1).Resize(, 2).Value = ws.Cells(i, 1).Resize(, 2).Value
            Set destCell = ws.Cells(newRowIndex + j, 3)
            destCell.Value = lines(j)
            
            lineStart = InStr(1, srcCell.Value, lines(j), vbTextCompare)
            If lineStart > 0 Then
                For charIndex = 1 To Len(lines(j))
                    destCell.Characters(charIndex, 1).Font.Color = srcCell.Characters(lineStart + charIndex - 1, 1).Font.Color
                Next charIndex
            End If
        Next j
        newRowIndex = newRowIndex + UBound(lines) + 1
    Next i
End Sub

to this

Column1	Column2	Column3
CellsA2	CellsB2	Text1
CellsA2	CellsB2	Text2
CellsA2	CellsB2	Text3
CellsA2	CellsB2	Text4

 

[Subash_G]

May be this,

Sub SplitLinesIntoRowsWithColorAndHeaders()
    Dim ws As Worksheet, lastRow As Long, i As Long, j As Long, newRowIndex As Long, lines As Variant
    Dim srcCell As Range, destCell As Range, charIndex As Long, lineStart As Long
   
    Set ws = ThisWorkbook.Sheets("Sheet1")
    lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
    newRowIndex = lastRow + 2
    ws.Rows(newRowIndex).Value = ws.Rows(1).Value
    ws.Rows(newRowIndex).Font.Color = ws.Rows(1).Font.Color
    newRowIndex = newRowIndex + 1
   
    For i = 2 To lastRow
        Set srcCell = ws.Cells(i, 3)
        lines = Split(srcCell.Value, vbLf)
       
        For j = 0 To UBound(lines)
            If j > 0 Then ws.Rows(newRowIndex + j).Insert xlDown
            ws.Cells(newRowIndex + j, 1).Resize(, 2).Value = ws.Cells(i, 1).Resize(, 2).Value
            Set destCell = ws.Cells(newRowIndex + j, 3)
            destCell.Value = lines(j)
           
            lineStart = InStr(1, srcCell.Value, lines(j), vbTextCompare)
            If lineStart > 0 Then
                For charIndex = 1 To Len(lines(j))
                    destCell.Characters(charIndex, 1).Font.Color = srcCell.Characters(lineStart + charIndex - 1, 1).Font.Color
                Next charIndex
            End If
        Next j
        newRowIndex = newRowIndex + UBound(lines) + 1
    Next i
End Sub

View attachment 122238
to this

Column1	Column2	Column3
CellsA2	CellsB2	Text1
CellsA2	CellsB2	Text2
CellsA2	CellsB2	Text3
CellsA2	CellsB2	Text4

Thank you very much, Sam! Its working fine as expected!!

Thanks,
Subash.