我想加入來自 3 個單元格的文本，同時保持單元格的格式。我在互聯網上查看，在我看來，Excel 中的 textjoin 函式無法保留格式。如下圖所示，我想將第 1-3 列中的文本與每個文本之間的雙線連接起來。
我目前使用=A2&CHAR(10)&CHAR(10)&B2&CHAR(10)&CHAR(10)&C2來獲取第 4 列中顯示的內容。但是，我的目標是獲取第 5 列中顯示的內容。
順便說一句，我有大量的這些細胞要加入。任何自動方式將不勝感激！有沒有人對此有想法？非常感謝。
uj5u.com熱心網友回復：
加入保留字體格式的單元格
- 假設資料（表）是連續的（沒有空行或列），它從單元格開始，
A1并且有一行標題。 - 將完整代碼復制到標準模塊中，例如
Module1. - 調整常量部分中的值（例如，要在結果單元格中獲得額外的換行符（“空行”），請使用
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
轉載請註明出處，本文鏈接：https://www.uj5u.com/net/348383.html