Excel 拆分文本保持字体颜色

Question

我正在尝试将单元格内的文本分隔到不同的单元格中，并保持每个字母的字体颜色。 前任。 |霍利·史密斯（蓝色）、杰克·汤普森（绿色）、亚当·米尔斯（红色）| 进入|霍利·史密斯（蓝色）|杰克·汤普森（绿色）|亚当·米尔斯（红色）| 我需要所有单元格位于同一行，因为它是一个很长的列表。

非常感谢任何帮助！

我在另一个问题上找到了下面的内容，但我需要它在每个“，”而不是“”处切割单元格。另外，代码正在转置结果，我需要它们在同一行。

Sub splitWithColor()
    Dim vStr As Variant, v
    Dim rSrc As Range, rRes As Range
    Dim I As Long, J As Long

'Note we are working with "active sheet"
'you should have stronger definitions in final product
Set rSrc = Range("A1")
Set rRes = Range("A3")

vStr = Split(rSrc.Value2)

Application.ScreenUpdating = False

Set rRes = rRes.Resize(UBound(vStr) + 1)
rRes.Value = WorksheetFunction.Transpose(vStr)
I = 0
J = 1
For Each v In vStr
    rRes.Offset(I)(1).Font.Color = rSrc.Characters(J, 1).Font.Color
    I = I + 1
    J = J + Len(v) + 1
Next v

End Sub```

Answer 1

正如 BigBen 所写，您可以将分隔符作为 split 函数的第二个参数提供，因此在您的情况下，这将是

","

。

下面的例程很灵活，您可以提供不同的分隔符并指定是否要水平或垂直书写单词。然后，它还会逐个字符地复制字体颜色，以便包含多种颜色的单词在复制后看起来相同。如果需要，您还可以复制其他属性，但请注意，这会减慢代码速度。

我添加了

lTrim

函数来消除前导空白，这使得在原始单元格文本中获得正确位置有点棘手，我为此引入了变量

blankCount

。

Sub SplitFormattedText(sourceCell As Range, destcell As Range, Optional delimiter As String = ",", Optional horizontal As Boolean = True)
    Dim words() As String
    words = Split(sourceCell, delimiter)
    
    Dim rowOffset As Long, colOffset As Long
    rowOffset = 0
    colOffset = 0
    
    Dim wordStartPos As Long
    wordStartPos = 0
    
    Dim i As Long
    For i = LBound(words) To UBound(words)
        Dim cell As Range
        Set cell = destcell.Offset(rowOffset, colOffset)
        Dim word As String
        word = LTrim(words(i))
        Dim blankCount As Long
        blankCount = Len(words(i)) - Len(word)  ' Number of leading blanks
        
        cell.Value = word    ' Write the (trimmed) word into cell
        
        ' Now copy the formatting character by character from the source cell
        Dim chrIndex As Long
        For chrIndex = 1 To Len(words(i))
            Dim sourceChrIndex As Long
            sourceChrIndex = wordStartPos + chrIndex + blankCount
            cell.Characters(chrIndex, 1).Font.Color = sourceCell.Characters(sourceChrIndex, 1).Font.Color
            'cell.Characters(chrIndex, 1).Font.Size = sourceCell.Characters(sourceChrIndex, 1).Font.Size
            'cell.Characters(chrIndex, 1).Font.Name = sourceCell.Characters(sourceChrIndex, 1).Font.Name
            'cell.Characters(chrIndex, 1).Font.Bold = sourceCell.Characters(sourceChrIndex, 1).Font.Bold
            'cell.Characters(chrIndex, 1).Font.Italic = sourceCell.Characters(sourceChrIndex, 1).Font.Italic
        Next chrIndex
        wordStartPos = wordStartPos + Len(words(i)) + Len(delimiter)
        ' increment offset so next word is written to next cell
        If horizontal Then colOffset = colOffset + 1 Else rowOffset = rowOffset + 1
    Next i
End Sub

做一个测试：

Sub test()
    With ActiveSheet
        SplitFormattedText .Range("A1"), .Range("B1"), ",", True
        SplitFormattedText .Range("A1"), .Range("A2"), ",", False
    End With
End Sub

单元格 B1:D1 填充了对例程的第一次调用，A2:A4 填充了第二次调用：