VBA para mover dados específicos de uma coluna para outra

Question

Eu tentei solicitar ajuda antes, mas não recebi respostas úteis.

Eu preciso de uma macro / VBA que mova qualquer palavra em vermelho da coluna A para a coluna C como uma lista.

No entanto, se a mesma palavra for destacada mais de uma vez na coluna A, só quero que essa palavra entre na coluna C uma vez (sem duplicatas), a menos que seja uma string.

meus dados são os seguintes

Eutenteicriarumvbaparaisso(abaixo),masnãofuncionacomoeugostariaquefosse...

Subcopy_red()DimLastRowAsLong,xAsLong,yAsLong,txt1AsString,txtAsStringLastRow=ActiveSheet.Cells(Rows.Count,1).End(xlUp).RowForx=1ToLastRowtxt1=""
    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

O resultado que recebo é o seguinte:

Oqueeugostariadealcançaréoseguinte:

Qualquer ajuda seria realmente apreciada, pois eu não saberia por onde começar ...

Obrigado

    

Answer 1

Você pode adicionar código ( ActiveSheet.Range().RemoveDuplicates ) para dizer à planilha para remover duplicatas do intervalo fornecido. Adicionar C:C ao intervalo na planilha ativa cobrirá toda a coluna. Se você precisar de um intervalo específico, poderá alterá-lo para o intervalo de células específico necessário.

Aqui está uma linha que você pode adicionar ao final do código que você compartilhou.

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

    

Answer 2

(a resposta de CharlieRB está incluída aqui quando ele postou a resposta 1,3 anos antes de mim)
A parte que ainda está faltando é dividir várias frases vermelhas da mesma célula em várias entradas na sua lista. Isso porque você não coloca a frase na sua lista até passar por todo o texto da célula. Você precisa ter um escape embutido no laço FOR para armazenar o resultado sempre que você apertar o texto preto após o texto vermelho, assim como ter um no final (caso o último caractere seja vermelho)

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