Combine text in cells with font color retained

[harky]

				Result
1	2	3	4	1234
1		3		13

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]

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]

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]

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​

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]

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]

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]

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

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]

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

MACRO_For-BP.xlsm
	A	B	C	D	E
2	39, 53, 81, 109	39, 53, 81, 109	39, 53, 81, 109	39, 53, 81, 109
3	1		3	4
Sheet2

 

[Zot]

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

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]

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

 

[harky]

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

View attachment 82018

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