Question

我正在构建一些代码，部分地从其他帖子中剪切和粘贴。我需要使用VBA代码进行合并，以保持格式并遍历各行以在每行的最后一个单元中输出。（无法粘贴图片），因此希望说明清楚：

在A1：D1中，值是红色，蓝色，绿色
在A2：D2中，值为黄色，紫色，橙色

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首选代码不允许遍历Range。修改了他的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

结果如此处所附快照所示。

连接vba excel保留格式

2 个答案: