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

 

[harky]

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

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]

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]

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]

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]

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]

@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]

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