VBA to move specific data from one column to another

Question

I've tried requesting help with this before but have received no helpful responses.

I need a Macro/VBA that moves any word in red from column A into column C as a list.

However if the same word is highlighted more than once in column A, I only want that word to go into column C once (no duplicates), unless its a string.

my data is as follows

I've tried creating a vba for this (below) but it doesn't work how i would like it to...

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

The result i get is as follows:

what i would like to achieve is the following:

Any help would really be appreciated as I wouldn't know where to begin...

Thanks

Solution 1

(CharlieRB's answer is included here as he posted the answer 1.3 years before me)
The piece you're still missing is splitting multiple red phrases from the same cell into multiple entries in your list. That is because you don't put the phrase in your list until you go through all the text in the cell. You need to have an escape built in the FOR loop to store the result whenever you hit black text after red text as well as having one at the end (in case the last character is red)

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

Solution 2

You can add code (ActiveSheet.Range().RemoveDuplicates) to tell the sheet to remove duplicates from the range given. Adding C:C the range in the active sheet will cover the entire column. If you need a specific range, you can change it to the specific cell range you need.

Here is a line you can add to the end of the code you shared.

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

Comments

[CharlieRB]

Although you've done a better job of asking in this post, you really should have improved the previous question, rather than posting the same question again. It is likely you didn't get any response for the reasons posted in the comments of the first post.

[TheUser1024]

I think you might benefit from describing what you want to achieve instead of describing this tiny part of your particular solution. Where do your strings come from, what are you planning on doing with them? The picture of what you want to achieve is confusing me. How can it say "how much" in line 22 for example or "transferring" in line two? Those words are not part of the string in col A.

[slhck]

As @CharlieRB said, in the future please don't repost your question, but rather edit the previous one instead. I closed the other one as a duplicate for now.

[Jez Vander Brown]

if people don't have a solution to my request, then please refrain from the petty comments.

[CharlieRB]

These are not petty comments. We are trying to help you improve your questions so you can not only get a helpful answer, but so your question and the answers are useful to this community. Unfortunately, those who choose to ignore the purpose and function of this site, get little help when they bite the hand that helps them. The quality of help is directly related to the quality of the information given in the question. Good luck with your project.

[Jez Vander Brown]

I find it highly frustrating that you presume I haven't included as much information as possible, if I had more information to provide do you not think I would've included it. I've tried including as much information as I can, if you still can't help then I really don't see the need in the previous 4 condescending responses. If this wasn't intentional, then you all should re-think the way you respond to posters instead of chastising them.