带格式的Textjoin

Question

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

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

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

​

​

Answer 1

保持字体格式的联接单元格

假定数据(表)是连续的(没有空行或列)，它从单元格Module1.

• Adjust开始，并且有一行标题。

• 将完整的代码复制到一个标准模块中，例如，将常量部分中的值(例如，获取结果单元格中额外的换行(“空行”)使用Const Delimiter As String = vbLf & vbLf).

• You只运行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