VBA для перемещения определенных данных из одного столбца в другой

Question

Я пытался запросить помощь с этим раньше, но не получил никаких полезных ответов.

Мне нужен Macro/VBA, который перемещает любое слово красного цвета из столбца A в столбец C в виде списка.

Однако, если одно и то же слово выделено более одного раза в столбце A, я хочу, чтобы это слово входило в столбец C только один раз (без дубликатов), если только оно не является строкой.

мои данные следующие

Я попытался создать VBA для этого (ниже), но он не работает так, как я хотел бы ...

Sub copy_red()
Dim LastRow  As Long, x As Long, y As Long, txt1 As String, txt As String
LastRow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
For x = 1 To LastRow
    txt1 = ""
    txt = Cells(x, 1)
    If txt <> "" Then
        For y = Len(txt) To 1 Step -1
            If Cells(x, 1).Characters(Start:=y, Length:=1).Font.Color = 255 Then
                txt1 = Cells(x, 1).Characters(Start:=y, Length:=1).Text & txt1
            End If
        Next y
        Cells(x, 3) = txt1
    End If
Next x
End Sub

Результат, который я получаю, выглядит следующим образом:

то, что я хотел бы достичь, это следующее:

Буду признателен за любую помощь, потому что я не знаю, с чего начать ...

Спасибо

Answer 1

(Ответ CharlieRB включен здесь, поскольку он отправил ответ за 1,3 года до меня)
Часть, которую вы до сих пор не нашли, разбивает несколько красных фраз из одной ячейки на несколько записей в вашем списке. Это потому, что вы не помещаете фразу в свой список, пока не пройдете весь текст в ячейке. Вам нужно встроить escape в цикл FOR чтобы сохранить результат всякий раз, когда вы нажимаете черный текст после красного текста, а также один в конце (в случае, если последний символ красный)

Sub copy_red()
    Dim LastRow As Long, x As Long, y As Long, txt1 As String, txt As String
    Dim copyRow As Long
    copyRow = 1
    LastRow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
    For x = 1 To LastRow
        txt1 = ""
        txt = Cells(x, 1)
        If txt <> "" Then
            For y = 1 To Len(txt)
                If Cells(x, 1).Characters(Start:=y, Length:=1).Font.Color = 255 Then
                    txt1 = txt1 & Cells(x, 1).Characters(Start:=y, Length:=1).Text
                Else
                    If txt1 <> "" Then
                        Cells(copyRow, 3) = txt1
                        copyRow = copyRow + 1
                        txt1 = ""
                    End If
                End If
            Next y
            If txt1 <> "" Then
                Cells(copyRow, 3) = txt1
                copyRow = copyRow + 1
                txt1 = ""
            End If
        End If
    Next x
    ActiveSheet.Range("C:C").RemoveDuplicates Columns:=1, Header:=xlNo
    ActiveSheet.Range("C:C").Font.Color = RGB(255, 0, 0)
End Sub

Answer 2

Вы можете добавить код (ActiveSheet.Range().RemoveDuplicates), чтобы указать листу удалить дубликаты из заданного диапазона. При добавлении C:C диапазон в активном листе будет охватывать весь столбец. Если вам нужен конкретный диапазон, вы можете изменить его на нужный вам диапазон ячеек.

Вот строка, которую вы можете добавить в конец кода, которым вы поделились.

ActiveSheet.Range("C:C").RemoveDuplicates Columns:=1, Header:=xlNo