2

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

enter image description here

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:

enter image description here

what i would like to achieve is the following:

enter image description here

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

Thanks

7
  • 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.
    – CharlieRB
    Oct 28, 2013 at 13:06
  • 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. Oct 28, 2013 at 13:15
  • the list is over a thousand rows long so i only screenshoted a small portion of the list which is why "how much" is in row 22 because it comes from further down the list in column A. I've explained what i want to achieve in both the question and also the last screenshot (column D) Oct 28, 2013 at 14:18
  • 1
    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.
    – slhck
    Oct 28, 2013 at 14:57
  • if people don't have a solution to my request, then please refrain from the petty comments. Oct 28, 2013 at 16:09

2 Answers 2

1

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
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

You must log in to answer this question.

Not the answer you're looking for? Browse other questions tagged .