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

Subash_G

New Member
Joined
Feb 9, 2025
Messages
3
Office Version
  1. Prefer Not To Say
Platform
  1. Windows
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.
 
May you can try this,
Book1
ABC
1Column1Column2Column3
2CellsA2CellsB2Text1 Text2 Text3
3CellsA3CellsB3Text1 Text2 Text3
4CellsA4CellsB4Text1 Text2 Text3
5CellsA5CellsB5Text1 Text2 Text3
6CellsA6CellsB6Text1 Text2 Text3
7CellsA4CellsB4Text1 Text2 Text3
8CellsA5CellsB5Text1 Text2 Text3
9CellsA6CellsB6Text1 Text2 Text3
Sheet1

VBA Code:
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
 
Upvote 0
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.
 
Upvote 0
May be this,
VBA Code:
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
1739223693940.png

to this 👇
Column1Column2Column3
CellsA2CellsB2Text1
CellsA2CellsB2Text2
CellsA2CellsB2Text3
CellsA2CellsB2Text4
 
Upvote 0
May be this,
VBA Code:
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 👇
Column1Column2Column3
CellsA2CellsB2Text1
CellsA2CellsB2Text2
CellsA2CellsB2Text3
CellsA2CellsB2Text4
Thank you very much, Sam! Its working fine as expected!!

Thanks,
Subash.
 
Upvote 0

Forum statistics

Threads
1,226,771
Messages
6,192,924
Members
453,767
Latest member
922aloose

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top