Combine text in cells with font color retained

H

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

Copy PDF to Excel
Select data in PDF. Paste to Microsoft Word. Copy from Word and paste to Excel.
Sort by date Sort by votes
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
drive.google.com

Book2.xlsm

drive.google.com drive.google.com

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
bebo021999 said:
drive.google.com

Book2.xlsm

drive.google.com drive.google.com

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
Click to expand...
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
bebo021999 said:
drive.google.com

Book2.xlsm

drive.google.com drive.google.com

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
Click to expand...
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
Zot said:
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
Click to expand...
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
You must log in or register to reply here.

Similar threads

E
  • Question Question
VBA code grouped into 1 line according to item
Replies
1
Views
181
RajeshKumar1313
R
J
  • Solved
Create Word document and center title
Replies
5
Views
531
Tetra201
Tetra201
I
  • Solved
DTPicker1 value to worksheet advice
Replies
2
Views
172
ipbr21054
I
E
  • Solved
VBA code to change color of text based on location of active cell?
2
Replies
13
Views
725
Akuini
Akuini
K
  • Solved
VBA change the font of the first letter only in each cell in a range to a specific font
Replies
1
Views
453
Fluff
Fluff

Forum statistics

Threads
1,223,905
Messages
6,175,297
Members
452,633
Latest member
DougMo

Share this page

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