excel - 带格式的文本连接

Question

我想加入来自 3 个单元格的文本，同时保持单元格的格式。我查看了互联网，在我看来，Excel 中的 textjoin 函数无法保留格式。如下图所示，我想加入第 1-3 列的文本，每个文本之间有一条双线。

我目前使用 =A2&CHAR(10)&CHAR(10)&B2&CHAR(10)&CHAR(10)&C2 来获取第 4 列中显示的内容。但是，我相反，我们的目标是获得第 5 列中显示的内容。

顺便说一句，我有很多这样的小组要加入。任何自动方式将不胜感激!有人对此有想法吗？非常感谢。

Answer 1

加入保留字体格式的单元格

• 假设数据(表)是连续的(没有空行或空列)，它从单元格 A1 开始，并且有一行标题。
• 将完整代码复制到标准模块中，例如模块 1。
• 调整常量部分中的值(例如，要在结果单元格中获得额外的换行符(“空行”)，请使用 Const Delimiter As String = vbLf & vbLf)。
• 您只运行 JoinCells 过程。其余的正在调用。

Option Explicit

Sub JoinCells()
' Needs the 'JoinCellsPreserveFontFormatting' and 'CopyFontFormatting' procedures.
    Const ProcTitle As String = "Join Cells"
    
    Const wsName As String = "Sheet1" ' Worksheet (Tab) Name
    Const sCols As Long = 3 ' Number of Source Columns to Join
    Const dCol As String = "D" ' Destination Column
    Const Delimiter As String = vbLf
    
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    Dim ws As Worksheet: Set ws = wb.Worksheets(wsName)
    Dim scrrg As Range: Set scrrg = ws.Range("A1").CurrentRegion ' has headers
    Dim srg As Range
    Set srg = scrrg.Resize(scrrg.Rows.Count - 1, sCols).Offset(1) ' no headers
    
    Application.ScreenUpdating = False
    
    Dim srrg As Range ' Source Row Range
    Dim dCell As Range ' Destination Cell Range

    For Each srrg In srg.Rows
        Set dCell = srrg.EntireRow.Columns(dCol)
        JoinCellsPreserveFontFormatting srrg, dCell, Delimiter
    Next srrg

    Application.ScreenUpdating = True

    MsgBox "Data copied. Font formatting preserved.", vbInformation, ProcTitle

End Sub

Sub JoinCellsPreserveFontFormatting( _
        ByVal SourceRange As Range, _
        ByVal DestinationCell As Range, _
        Optional ByVal Delimiter As String = vbLf)
' Needs the 'CopyFontFormatting' procedure.
    
    Dim sCell As Range
    Dim dString As String
    
    For Each sCell In SourceRange.Cells
        dString = dString & CStr(sCell) & Delimiter
    Next sCell
    Dim delLen As Long: delLen = Len(Delimiter)
    dString = Left(dString, Len(dString) - delLen)
    
    ' Alternatively...
    ' For one row:
    'dString = Join(Application.Transpose( _
        Application.Transpose(SourceRange.Value)), Delimiter)
    ' For one column:
    'dString = Join(Application.Transpose(SourceRange.Value), Delimiter)
    
    DestinationCell.Value = dString
    
    Dim sFont As Font
    Dim s As Long
    Dim dFont As Font
    Dim d As Long
    
    For Each sCell In SourceRange.Cells
        For s = 1 To sCell.Characters.Count
            d = d + 1
            Set sFont = sCell.Characters(s, 1).Font
            Set dFont = DestinationCell.Characters(d, 1).Font
            CopyFontFormatting sFont, dFont
        Next s
        d = d + delLen
    Next sCell

End Sub

Sub CopyFontFormatting( _
    ByVal SourceFont As Font, _
    ByVal DestinationFont As Font)
    
    With DestinationFont
        .FontStyle = SourceFont.FontStyle
        .Color = SourceFont.Color
        .Underline = SourceFont.Underline
        ' Add more, or not.
        '.Size = SourceFont.Size
    End With
    
End Sub