Разделение строки ячейки Excel с сохранением цветового форматирования шрифта

Question

Я уже писал этот вопрос, но он был признан слишком расплывчатым. Итак, здесь я пытаюсь снова.

У меня есть ячейка с буквами разных цветов. Каждая буква равномерно распределена между собой (см. Ниже). Мне нужно разделить их на отдельные ячейки с сохранением их цветового форматирования с использованием VBA.

Фактические цвета шрифта выражены в [] скобках

Мне нужно разделить:

  |A                              |
1 |Alan[Red] Betty[Blue] Cass[Red]|

Into:

  |A           |
1 |Alan[Red]   |
2 |Betty[Blue] |
3 |Cass[Red]   |

Мне удалось извлечь только значения в исходной строке, но не форматирование отдельной буквы.

Я также пытался Text to Columns, но все разделенные ячейки не отформатированы. Даже ручное копирование не работает, если в ячейке выделена только частичная строка.

Как можно выполнить sh разбиение строки при сохранении цвета с помощью VBA?

Я использовал код часть большего количества других вещей, но упрощенная логика c такова:

Sub test()
Dim strLength As Long
Dim breakPos As Long
Dim spaceCount As Long

strLength = Len(Cells(1, 1))
spaceCount = strLength - Len(Replace(Cells(1, 1), " ", ""))

For i = 1 To spaceCount
    strLength = Len(Cells(i, 1))
    breakPos = InStr(1, Cells(i, 1), " ")
    Cells(i + 1, 1) = Right(Cells(i, 1), strLength - breakPos)
    Cells(i, 1) = Left(Cells(i, 1), breakPos - 1)
Next i

End Sub

Answer 1

Это, кажется, приводит к тому, что вы описываете.

• Разделите ячейку на слова
• Запишите слова в новое местоположение
• Проверьте шрифт оригинальное слово и установите этот цвет в новом месте

В своем «производственном» коде вы захотите более строго объявить рабочую книгу и рабочий лист, и вы, вероятно, будете делать это более чем на в одну ячейку, поэтому вам, вероятно, потребуется добавить несколько циклов и операторов для настройки для различных диапазонов, отличных от A1 и A3, как показано в вашем вопросе.

Option Explicit
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 2

Попробуйте этот код, пожалуйста. Все слова в анализируемой строке должны иметь одинаковый цвет шрифта для всех их символов , они должны быть разделены пробелами ("") . Результат будет возвращен ниже обработанной ячейки. В этом примере ниже активной ячейки. При необходимости, конечно, он может заменить выбранную ячейку, но вы не можете повторить тест для той же ячейки ...

Sub splitByWordsKeepingFontColor()
  Dim c As Range, i As Long, arrRes As Variant, arrCol() As Variant
    Set c = ActiveCell: If c.Text = "" Then MsgBox "Emply cell selection...": Exit Sub
    arrRes = Split(c.Text, " ")
    If UBound(arrRes) = 0 Then MsgBox "No strings separated by space ("" "") exist in """ & _
                                                               c.Text & """.": Exit Sub
    ReDim arrCol(UBound(arrRes))
      For i = 0 To UBound(arrRes)
        arrCol(i) = c.Characters(InStr(c.Text, arrRes(i)), _
                                                    Len(arrRes(i))).Font.ColorIndex
      Next i
      c.Offset(1, 0).Resize(UBound(arrRes) + 1, 1) = _
                                    Application.WorksheetFunction.Transpose(arrRes)
      For i = 0 To UBound(arrCol)
        c.Offset(i + 1, 0).Font.ColorIndex = arrCol(i)
      Next i      
End Sub