конкатенация VBA Excel сохранить формат

Question

Я строю некоторый код, частично вырезанный и вставленный из других постов.Мне нужно объединить с кодом VBA, сохраняя формат и проходя через строки для вывода в последнюю ячейку в каждой строке.(Невозможно вставить изображение), поэтому надеюсь, что описание понятно:

• В A1: значения D1 - КРАСНЫЙ, СИНИЙ, ЗЕЛЕНЫЙ
• В A2: значения D2 - ЖЕЛТЫЙ, ФИОЛЕТОВЫЙ, ОРАНЖЕВЫЙ

OUTPUT IN E1 должен объединить эти значения, сохраняя цвет шрифта.Каждое значение должно иметь «ALT ENTR», чтобы дать разрыв строки.

Следующая строка должна отображаться в E2, и так далее

'************************************************************************************
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
'*****************************************************************************

Answer 1

Я думаю, вам нужно что-то подобное.Измените исходный шрифт и форматы в соответствии с вашими требованиями.

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

Снимок пробной версии:

РЕДАКТИРОВАТЬ: OP Предпочитаемый код не позволяет циклически проходить через диапазон,В его Sub Test() внесены изменения, позволяющие циклически проходить через диапазон.

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

Результаты приведены в соответствии с прилагаемым снимком.

Answer 2

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

введите описание изображения здесь