连接vba excel保持格式

Question

我正在构建一些代码，部分是从其他帖子中剪切和粘贴的。我需要与保持格式的 VBA 代码连接并在行中运行以在每行的最后一个单元格中输出。 （无法粘贴图片）所以希望描述清楚：

• 在 A1:D1 中的值为 RED、BLUE、GREEN
• 在 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

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

Answer 2

我认为你需要这样的东西。根据您的要求更改源字体和格式。

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

结果与此处附加的快照一致。