concatenate vba excel keep format

1
votes

I am building on some code, partly cut and paste from other posts. I need to concatenate with a VBA code keeping the format and running through rows to output in last cell in each row. (Can't paste image) so hope description is clear:

  • In A1:D1 values are RED,BLUE,GREEN
  • In A2:D2 Values are YELLOW,PURPLE,ORANGE

OUTPUT IN E1 should concatenate these values, keeping font colour. Each value should have "ALT ENTR" to give line break.

Next row should be displayed in E2, and so on

'************************************************************************************
Sub test()


Dim rng As Range: Set rng = Application.Range("a1:c1") 'Not yet looping
Dim row As Range

For Each row In rng.Rows
    'Debug.Print col.Column
    Call concatenate_cells_formats(Cells(1, 4), rng) 'Not yet looping

Next row


End Sub

Sub concatenate_cells_formats(cell As Range, source As Range)
'Anon

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
            .ColorIndex = c.Font.ColorIndex
            End With
            .Characters(Start:=i + Len(c), Length:=1).Font.Size = 1
        i = i + Len(Trim(c)) + 1
        Next c

    End With

End Sub
'*****************************************************************************
2
excelvbaconcatenation
The "ALT ENTR", as you call it, can be achieved by concatenating vbCrLf (Carriage Return, Line Feed) into the string where you want the New Line to start, and making sure that the .WrapText property is True for that cell - Chronocidal
Great stuff, works like a charm. Had to input "dim i as integer" and change sheet name - Kobus van Zyl
Your program does not include your specified requirement that Each value should have "ALT ENTER" to give line break.and looping. - skkakkar
Also your specified range is In A1:D1 values are RED,BLUE,GREEN where as your program mentions range A1:C1 - skkakkar
Please see my edited post. I have modified your your Sub test() to allow for looping in the range and it uses your preferred concatenate sub routine. - skkakkar

2 Answers

0
votes
Option Explicit

Sub concColour()

    Dim i As Long, j As Long, s As Long, l As Long, clr As Long, vals As Variant

    With Worksheets("sheet4")
        For i = 1 To .Cells(.Rows.Count, "A").End(xlUp).Row

            vals = Application.Transpose(Application.Transpose(Intersect(.Range("A:D"), .Rows(i)).Value2))
            .Cells(i, "E") = Join(vals, vbLf)

            s = 1
            For j = LBound(vals) To UBound(vals)
                l = Len(vals(j))
                clr = .Cells(i, "A").Offset(0, j - 1).Font.Color
                With .Cells(i, "E").Characters(Start:=s, Length:=l).Font
                    .Color = clr
                End With
                s = s + l + 1
            Next j

            .Cells(i, "E").Font.Size = 4

        Next i
    End With

End Sub

enter image description here

0
votes

I think you require something like this. Change source font and formats as per your requirement.

Sub Adding_T()
    Dim lena As Integer
    Dim lenc As Integer
    Dim lend As Integer
    Dim lene As Integer
    Dim LastRow As Long
    Dim nrow As Long

    With Worksheets("Sheet2") 'Change sheet as per your requirement
        LastRow = .Cells(.Rows.Count, "A").End(xlUp).row
        For nrow = 1 To LastRow
                .Range("E" & nrow) = .Range("A" & nrow).Value2 & Chr(13) & Chr(10) & .Range("B" & nrow).Value2 & _
    Chr(13) & Chr(10) & .Range("C" & nrow).Value2 & Chr(13) & Chr(10) & .Range("D" & nrow).Value2

    lena = Len(.Range("A" & nrow).Value2)
    lenc = lena + 2 + Len(.Range("B" & nrow).Value2)
    lend = lenc + 2 + Len(.Range("C" & nrow).Value2)
    lene = lend + 2 + Len(.Range("D" & nrow).Value2)


    For i = 1 To lena
         .Range("E" & nrow).Characters(Start:=i, Length:=1).Font.Color = _
                    .Range("A" & nrow).Characters(Start:=i, Length:=1).Font.Color
    Next i

    For i = lena + 2 To lenc
         .Range("E" & nrow).Characters(Start:=i, Length:=1).Font.Color = _
                    .Range("B" & nrow).Characters(Start:=i, Length:=1).Font.Color
    Next i

    For i = lenc + 2 To lend
         .Range("E" & nrow).Characters(Start:=i, Length:=1).Font.Color = _
                    .Range("C" & nrow).Characters(Start:=i, Length:=1).Font.Color
    Next i

    For i = lend + 2 To lene
     .Range("E" & nrow).Characters(Start:=i, Length:=1).Font.Color = _
                    .Range("D" & nrow).Characters(Start:=i, Length:=1).Font.Color
            Next i

    Next

    End With

 End Sub

Snapshot of trial: enter image description here

EDIT: OP Preferred code does not permit looping through the Range. Amended his Sub Test() to allow looping through the range.

Sub  Test2()
        Dim ws As Worksheet
        Dim LastRow As Long
        Set ws = ThisWorkbook.ActiveSheet
        Dim rng As Range
        Dim row As Range
        Dim rw As Long
        LastRow = ws.Cells(Rows.Count, "A").End(xlUp).row
        rw = 1
        For rw = 1 To LastRow
            Set rng = ws.Range("A" & rw & ":C" & rw)
            Call concatenate_cells_formats(Cells(rw, 4), rng)
        Next
 End Sub

Results are as per snapshot appended here.

test_modify