Combine text in cells with font color retained

harky

Active Member
Joined
Apr 8, 2010
Messages
405
Office Version
  1. 2021
  2. 2019
Platform
  1. Windows
Result
12341234
1313

i had one code but it doesnt work well.....

VBA Code:
Sub SetValue()
    Dim s1 As String
    Dim s2 As String
    Dim s3 As String
    Dim s4 As String
    
    s1 = Range("A2").Text
    s2 = Range("B2").Text
    s3 = Range("C2").Text
    s4 = Range("D2").Text
        
    Range("E2").Value = s1 & s2 & s3 & s4
          
        With Range("E2").Characters(1, Len(s1)).Font
            .Name = Range("A2").Font.Name
            .Color = Range("A2").Font.Color
            .Bold = Range("A2").Font.Bold
            .Italic = Range("A2").Font.Italic
        End With
            
        With Range("E2").Characters(Len(s1) + 1).Font
            .Name = Range("B2").Font.Name
            .Color = Range("B2").Font.Color
            .Bold = Range("B2").Font.Bold
            .Italic = Range("B2").Font.Italic
        End With
        
        With Range("E2").Characters(Len(s1) + 2).Font
            .Name = Range("C2").Font.Name
            .Color = Range("C2").Font.Color
            .Bold = Range("C2").Font.Bold
            .Italic = Range("C2").Font.Italic
        End With
        
        With Range("E2").Characters(Len(s1) + 3).Font
            .Name = Range("D2").Font.Name
            .Color = Range("D2").Font.Color
            .Bold = Range("D2").Font.Bold
            .Italic = Range("D2").Font.Italic
        End With
        
        
End Sub
 

Excel Facts

Can Excel fill bagel flavors?
You can teach Excel a new custom list. Type the list in cells, File, Options, Advanced, Edit Custom Lists, Import, OK
bascially is join (text retail the colour, bold, underline etc) on Row A2 to D2 to E2
so on so on for the rest of the row
 
Upvote 0
i found this but the first letter color did not retain... if there is empty cell


VBA Code:
Sub test()
    Dim cell   As Range
    Application.ScreenUpdating = False
    For Each cell In Range("A2", Range("A" & Rows.Count).End(xlUp))
        Call concatenate_cells_formats(cell.Offset(, 4), cell.Resize(, 4)) 'Destination column A, Source B:F
    Next cell
    Application.ScreenUpdating = True
End Sub

Sub concatenate_cells_formats(cell As Range, source As Range)

    Dim c      As Range
    Dim i      As Integer

    i = 1

    With cell
   
        .Value = vbNullString
        .ClearFormats

        For Each c In source
            If Len(c.Value) Then .Value = .Value & "," & Trim(c)
        Next c
       
        .Value = Trim(Mid(.Value, 2))

        For Each c In source
       
            With .Characters(Start:=i, Length:=Len(Trim(c))).Font
                .Name = c.Font.Name
                .FontStyle = c.Font.FontStyle
                .Size = c.Font.Size
                .Strikethrough = c.Font.Strikethrough
                .Superscript = c.Font.Superscript
                .Subscript = c.Font.Subscript
                .OutlineFont = c.Font.OutlineFont
                .Shadow = c.Font.Shadow
                .Underline = c.Font.Underline
                .Color = c.Font.Color
            End With
           
            .Characters(Start:=i + Len(c) + 1, Length:=1).Font.Size = 1
            i = i + Len(Trim(c)) + 1

        Next c

    End With

End Sub
 
Upvote 0

One way:
VBA Code:
Option Explicit
Sub test()
Dim i&, j&, k&
With Range("E2:E3")
    .ClearContents
End With
For i = 2 To 3 ' from row 2 to row 3
    k = 0
    For j = 1 To 4 'from column A:D
        Cells(i, "E").Value = Cells(i, "E").Value & Cells(i, j)
    Next
    For j = 1 To 4
        If Cells(i, j) <> "" Then
            k = k + 1
            With Cells(i, "E").Characters(k, 1).Font
                .Name = Cells(i, j).Font.Name
                .Size = Cells(i, j).Font.Size
                .Color = Cells(i, j).Font.Color
                .Bold = Cells(i, j).Font.Bold
                .Italic = Cells(i, j).Font.Italic
                .Strikethrough = Cells(i, j).Font.Strikethrough
                'Add more properties, if needed
            End With
        End If
    Next
Next
End Sub
 

Attachments

  • Capture.JPG
    Capture.JPG
    35.5 KB · Views: 9
Upvote 0

One way:
VBA Code:
Option Explicit
Sub test()
Dim i&, j&, k&
With Range("E2:E3")
    .ClearContents
End With
For i = 2 To 3 ' from row 2 to row 3
    k = 0
    For j = 1 To 4 'from column A:D
        Cells(i, "E").Value = Cells(i, "E").Value & Cells(i, j)
    Next
    For j = 1 To 4
        If Cells(i, j) <> "" Then
            k = k + 1
            With Cells(i, "E").Characters(k, 1).Font
                .Name = Cells(i, j).Font.Name
                .Size = Cells(i, j).Font.Size
                .Color = Cells(i, j).Font.Color
                .Bold = Cells(i, j).Font.Bold
                .Italic = Cells(i, j).Font.Italic
                .Strikethrough = Cells(i, j).Font.Strikethrough
                'Add more properties, if needed
            End With
        End If
    Next
Next
End Sub
i try but it dont work .. it work if there cell only had 1 letter but if there is more than 1.. it dont work anymore


this is the result i test


Book1.xlsm
ABCDE
212345678901234561234567890123456
Sheet1


and every break should has a ", " comma with space


result show be like this

12345678901234561234, 5678, 90123, 456
 
Last edited:
Upvote 0

One way:
VBA Code:
Option Explicit
Sub test()
Dim i&, j&, k&
With Range("E2:E3")
    .ClearContents
End With
For i = 2 To 3 ' from row 2 to row 3
    k = 0
    For j = 1 To 4 'from column A:D
        Cells(i, "E").Value = Cells(i, "E").Value & Cells(i, j)
    Next
    For j = 1 To 4
        If Cells(i, j) <> "" Then
            k = k + 1
            With Cells(i, "E").Characters(k, 1).Font
                .Name = Cells(i, j).Font.Name
                .Size = Cells(i, j).Font.Size
                .Color = Cells(i, j).Font.Color
                .Bold = Cells(i, j).Font.Bold
                .Italic = Cells(i, j).Font.Italic
                .Strikethrough = Cells(i, j).Font.Strikethrough
                'Add more properties, if needed
            End With
        End If
    Next
Next
End Sub
take text in cells A2, B2, C2, D2 and concatenate in E2, keeping the individual colours/bold/etc
 
Upvote 0
this work great but if i add in comma in-between break cell.. it wont work anymore


VBA Code:
Sub test()
Call concatenate_cells_formats(Range("E2"), Range("A2,B2,C2,D2"))
End Sub

Sub concatenate_cells_formats(cell As Range, source As Range)
'Erik Van Geit
'070607

Dim c As Range
Dim i As Integer

i = 1

    With cell
    .Value = vbNullString
    .ClearFormats
    
        For Each c In source
        .Value = .Value & " " & Trim(c)
        Next c

    .Value = Trim(.Value)

        For Each c In source
            With .Characters(Start:=i, Length:=Len(Trim(c))).Font
            .Name = c.Font.Name
            .FontStyle = c.Font.FontStyle
            .Size = c.Font.Size
            .Strikethrough = c.Font.Strikethrough
            .Superscript = c.Font.Superscript
            .Subscript = c.Font.Subscript
            .OutlineFont = c.Font.OutlineFont
            .Shadow = c.Font.Shadow
            .Underline = c.Font.Underline
            .Color = c.Font.Color
            End With
            .Characters(Start:=i + Len(c), Length:=1).Font.Size = 1
        i = i + Len(Trim(c)) + 1
        Next c

    End With

End Sub
 
Upvote 0
Try again:
VBA Code:
Option Explicit
Sub format()
Dim lr&, i&, j&, k&, t&, st As String
lr = Cells(Rows.Count, "A").End(xlUp).Row
Range("E2:E" & lr).ClearContents
For i = 2 To lr
    st = ""
    For j = 1 To 4
        st = IIf(st = "", "", st & ", ") & Cells(i, j)
    Next
    Cells(i, "E").Value = st
    k = 0
    For j = 1 To 4
        For t = 1 To Len(Cells(i, j))
            k = k + 1
            With Cells(i, "E").Characters(k, 1).Font
                .Color = Cells(i, j).Characters(t, 1).Font.Color
                .Size = Cells(i, j).Characters(t, 1).Font.Size
                .Bold = Cells(i, j).Characters(t, 1).Font.Bold
                .Strikethrough = Cells(i, j).Characters(t, 1).Font.Strikethrough
                .Italic = Cells(i, j).Characters(t, 1).Font.Italic
                'add more properties
            End With
        Next
        k = k + 2
    Next
Next
End Sub
Capture.JPG
 
Upvote 0
Here is another alternative. Modify to your need. Strangely, the result isnot captured by XL2BB :unsure:

Color.xlsm
ABCDE
1
21AQ234341AQ,234,3,4
312345678901234561234,5678,90123,456
41241,2,4
Sheet1


Select column E in respective row and run the macro below
VBA Code:
Sub Test()

Dim cell As Range, r As Range, rData As Range
Dim n As Long

Set r = ActiveCell
r.ClearContents
r.ClearFormats
Set rData = Range("A" & r.Row, "D" & r.Row)

r.NumberFormat = "@"
For Each cell In rData
    If Not cell = "" Then r = r & cell & ","
Next
r = Left(r, Len(r) - 1)

n = 1
For Each cell In rData
    With r.Characters(InStr(n, r.Value, cell.Value), Len(cell)).Font
        .Color = cell.Font.Color
        .Bold = cell.Font.Bold
    End With
    n = InStr(n, r.Value, cell.Value) + Len(cell)
Next

End Sub
 
Upvote 0
Here is another alternative. Modify to your need. Strangely, the result isnot captured by XL2BB :unsure:

Color.xlsm
ABCDE
1
21AQ234341AQ,234,3,4
312345678901234561234,5678,90123,456
41241,2,4
Sheet1


Select column E in respective row and run the macro below
VBA Code:
Sub Test()

Dim cell As Range, r As Range, rData As Range
Dim n As Long

Set r = ActiveCell
r.ClearContents
r.ClearFormats
Set rData = Range("A" & r.Row, "D" & r.Row)

r.NumberFormat = "@"
For Each cell In rData
    If Not cell = "" Then r = r & cell & ","
Next
r = Left(r, Len(r) - 1)

n = 1
For Each cell In rData
    With r.Characters(InStr(n, r.Value, cell.Value), Len(cell)).Font
        .Color = cell.Font.Color
        .Bold = cell.Font.Bold
    End With
    n = InStr(n, r.Value, cell.Value) + Len(cell)
Next

End Sub
thx.. i try it works if all cell is not blank

but.. if there is blank at one of the A B C D cell.. it has error...
 
Upvote 0

Forum statistics

Threads
1,223,238
Messages
6,170,939
Members
452,368
Latest member
jayp2104

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