# Combine text in cells with font color retained



## harky (Jan 2, 2023)

Result*1**2**3**4**12**3**4**1**3**1**3*

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


```
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
```


----------



## harky (Jan 2, 2023)

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


----------



## harky (Jan 3, 2023)

i found this but the first letter color did not retain... if there is empty cell



```
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
```


----------



## bebo021999 (Jan 3, 2023)

Book2.xlsm
					






					drive.google.com
				




One way:

```
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
```


----------



## harky (Jan 3, 2023)

bebo021999 said:


> Book2.xlsm
> 
> 
> 
> ...


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.xlsmABCDE212345678901234561234567890123456Sheet1

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


result show be like this


*1234**5678**90123**456**1234*, *5678*, *90123*, *456*


----------



## harky (Jan 3, 2023)

bebo021999 said:


> Book2.xlsm
> 
> 
> 
> ...


take text in cells A2, B2, C2, D2 and concatenate in E2, keeping the individual colours/bold/etc


----------



## harky (Jan 3, 2023)

this work great but if i add in comma in-between break cell.. it wont work anymore 



```
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
```


----------



## bebo021999 (Jan 3, 2023)

Try again:

```
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
```


----------



## Zot (Jan 3, 2023)

Here is another alternative. Modify to your need. Strangely, the result isnot captured by XL2BB 

Color.xlsmABCDE121AQ234341AQ,234,3,4312345678901234561234,5678,90123,45641241,2,4Sheet1

Select column E in respective row and run the macro below

```
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
```


----------



## harky (Jan 4, 2023)

Zot said:


> Here is another alternative. Modify to your need. Strangely, the result isnot captured by XL2BB
> 
> Color.xlsmABCDE121AQ234341AQ,234,3,4312345678901234561234,5678,90123,45641241,2,4Sheet1
> 
> ...


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...


----------



## harky (Jan 2, 2023)

Result*1**2**3**4**12**3**4**1**3**1**3*

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


```
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
```


----------



## Zot (Jan 4, 2023)

harky said:


> 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...


What error did you see? As in my sample Line 4, it worked flawlessly for me.


----------



## harky (Jan 4, 2023)

Zot said:


> What error did you see? As in my sample Line 4, it worked flawlessly for me.


Run-Time error 5
debug show error on this line.
r = Left(r, Len(r) - 1)


this is my first 2 row
i had error when i start runing it.. 


*39, 53, 81, 109**39, 53, 81, 109**39, 53, 81, 109**39, 53, 81, 109**1*​*3*​*4*​


----------



## Zot (Jan 4, 2023)

harky said:


> Run-Time error 5
> debug show error on this line.
> r = Left(r, Len(r) - 1)
> 
> ...


Run just fine on my Excel version. The line is just to remove the comma at the end. Try change it to

```
r = Left(r.Text, Len(r.Text) - 1)
```


----------



## harky (Jan 4, 2023)

Zot said:


> Run just fine on my Excel version. The line is just to remove the comma at the end. Try change it to
> 
> ```
> r = Left(r.Text, Len(r.Text) - 1)
> ```


i using excel 2021

i changed the line.. same error .


----------



## Zot (Jan 4, 2023)

harky said:


> i using excel 2021
> 
> i changed the line.. same error .


I noticed that when I copied your sample into my sheet, the value of each cell is not really what it looked like. Instead of *1*, *3*, or *4*; it was *1?*, *3?*, or *4?*. I can see this when debugging in VBA editor.

I wonder if this could be the cause. You probably copy this from table produced by other apps like in HTML format. When I re-entered the number, the invisible *?* was gone. I tried to add a simple clean function and it was gone too. I added a line before r = Left(r, Len(r) - 1) to become

```
r = Application.WorksheetFunction.Clean(r)
r = Left(r, Len(r) - 1)
```

See if this solves the problem.

There is a function by @Rick Rothstein  that remove all the invisible characters from string

```
Function CleanTrim(ByVal S As String, Optional ConvertNonBreakingSpace As Boolean = True) As String
  Dim X As Long, CodesToClean As Variant
  CodesToClean = Array(0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, _
                       21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, 127, 129, 141, 143, 144, 157)
  If ConvertNonBreakingSpace Then S = Replace(S, Chr(160), " ")
  For X = LBound(CodesToClean) To UBound(CodesToClean)
    If InStr(S, Chr(CodesToClean(X))) Then S = Replace(S, Chr(CodesToClean(X)), "")
  Next
  CleanTrim = WorksheetFunction.Trim(S)
End Function
```

Link








						VBA Remove all Non-Printable and special characters as well as Trim
					

Can someone help me with a macro to combine Removing all Non-Printable and special characters as well as Trim.  I'm using a trim macro at the moment and works great but isn't always removing hidden characters. Also could probably be better than this.  Sub Trim() ' ' Trim Macro ' Trim '...




					www.mrexcel.com


----------



## harky (Jan 4, 2023)

Zot said:


> I noticed that when I copied your sample into my sheet, the value of each cell is not really what it looked like. Instead of *1*, *3*, or *4*; it was *1?*, *3?*, or *4?*. I can see this when debugging in VBA editor.
> 
> I wonder if this could be the cause. You probably copy this from table produced by other apps like in HTML format. When I re-entered the number, the invisible *?* was gone. I tried to add a simple clean function and it was gone too. I added a line before r = Left(r, Len(r) - 1) to become
> 
> ...


tht strange.. because 1 2 3 is manual input.... not copy from somewhere

i try the above 2 line... still having same error on that part. 



```
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 = Application.WorksheetFunction.Clean(r)
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
        .FontStyle = cell.Font.FontStyle
        .Bold = cell.Font.Bold
    End With
    n = InStr(n, r.Value, cell.Value) + Len(cell)
Next

End Sub
```


----------



## harky (Jan 4, 2023)

Zot said:


> I noticed that when I copied your sample into my sheet, the value of each cell is not really what it looked like. Instead of *1*, *3*, or *4*; it was *1?*, *3?*, or *4?*. I can see this when debugging in VBA editor.
> 
> I wonder if this could be the cause. You probably copy this from table produced by other apps like in HTML format. When I re-entered the number, the invisible *?* was gone. I tried to add a simple clean function and it was gone too. I added a line before r = Left(r, Len(r) - 1) to become
> 
> ...


MACRO_For-BP.xlsmABCDE239, 53, 81, 10939, 53, 81, 10939, 53, 81, 10939, 53, 81, 1093134Sheet2


----------



## Zot (Jan 4, 2023)

harky said:


> tht strange.. because 1 2 3 is manual input.... not copy from somewhere
> 
> i try the above 2 line... still having same error on that part.
> 
> ...


Try remove the two line

```
r = Application.WorksheetFunction.Clean(r)
r = Left(r, Len(r) - 1)
```

You will get comma at the end but I wonder if the error is still there


----------



## bebo021999 (Jan 4, 2023)

@harky 
Have you tried my update version in #8? Does it work?


----------



## harky (Jan 5, 2023)

bebo021999 said:


> Try again:
> 
> ```
> Option Explicit
> ...


this work but if cell is blank.. got extra comma


----------



## harky (Jan 2, 2023)

Result*1**2**3**4**12**3**4**1**3**1**3*

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


```
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
```


----------



## harky (Jan 5, 2023)

Zot said:


> Try remove the two line
> 
> ```
> r = Application.WorksheetFunction.Clean(r)
> ...


yes u r right. there will comma at the end but it cannot go next row
even tot i got 2 row with letters/words


----------



## Zot (Jan 5, 2023)

harky said:


> yes u r right. there will comma at the end but it cannot go next row
> even tot i got 2 row with letters/words


I didn't get what you meant by  *it cannot go next row even tot i got 2 row with letters/words*

I wish I had the 2019 version


----------



## harky (Jan 5, 2023)

Zot said:


> I didn't get what you meant by  *it cannot go next row even tot i got 2 row with letters/words*
> 
> I wish I had the 2019 version


i mean my input was in first 2 row. but the result only in first row. the 2nd row is blank


----------



## Zot (Jan 5, 2023)

harky said:


> i mean my input was in first 2 row. but the result only in first row. the 2nd row is blank


The macro is executed line by line based on where you select the row. It was just meant to give idea as I have no idea how your approach is to your task. It is not automatic.

Do you want to complete the list first and then run macro that it will automatically go through all the list?
You data column is always 4 columns?


----------



## harky (Monday at 3:08 AM)

Zot said:


> The macro is executed line by line based on where you select the row. It was just meant to give idea as I have no idea how your approach is to your task. It is not automatic.
> 
> Do you want to complete the list first and then run macro that it will automatically go through all the list?
> You data column is always 4 columns?


as for now is 4 column.

the row is unlimited. 
but each row cell can be some filled or empty.


----------



## harky (Tuesday at 4:13 AM)

bebo021999 said:


> @harky
> Have you tried my update version in #8? Does it work?


this work but if cell is blank.. got extra comma..
can it be fixed?


----------



## Zot (Wednesday at 9:37 PM)

Here is revised code.
Condition:
Data is from column A to D. If you need to change last column then modify this line

```
Set rData = Range("A" & cell.Row, "*D*" & cell.Row)
```
Data starts from Row 2

You will be prompt to specify which column your answer would be in. Be careful not to overlap your data column as I did not put code to check on it.


```
Sub KeepFormat()

Dim strAns As String
Dim m As Long, n As Long, nData As Long, eRow As Long
Dim cell As Range, r As Range, rData As Range, rRow As Range

Again:
strAns = Application.InputBox("Enter output column", "INPUT")
If Not strAns Like "[a-zA-Z]" Then
    MsgBox "Enter column letter only": GoTo Again
End If
eRow = Cells(Rows.Count, "A").End(xlUp).Row
Set rRow = Range(strAns & "2", strAns & eRow)

For Each cell In rRow
    cell.ClearContents
    cell.ClearFormats
    Set rData = Range("A" & cell.Row, "D" & cell.Row)

    cell.NumberFormat = "@"
    m = 0
    nData = Application.WorksheetFunction.CountA(rData)
    For Each r In rData
        If Not r = "" And Not m = nData - 1 Then
            m = m + 1
            cell = cell & r.Value & ","
        Else
            cell = cell & r.Value
        End If
    Next
    cell = Application.WorksheetFunction.Clean(cell)

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

End Sub
```


----------

