VBA to cut colored text from one document and paste to another

Onjai · #1 08-17-2023, 12:44 PM

Hi,
Document contains this text:

1 Now a Green Text 2 Label this in Black
3 Soft Kitty
4 Dog owners are great.
5 Spelling is not my forte
6 Measure Twice
7 Distance Measure

The following code will find 1st instance of the yellow text and Cut/Paste it to a new document. On the second loop it crashes at Selection.Range.Paste with Object empty error.
Not sure what the issue is. Likely that I am quite new to VBA and Word docs. Any help would be appreciated.

Sub FindYellowText()

Dim oResponse As Document

Selection.HomeKey wdStory
With Selection.Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = ""
.MatchWildcards = False

.Forward = True
.Wrap = wdFindStop
.Font.ColorIndex = wdYellow
.Execute

Do Until Not .Found
If Selection.Range.Font.ColorIndex = wdYellow Then
Selection.Range.Cut
Set oResponse = Documents.Add
With oResponse
Selection.Range.Paste
End With
End If
.Execute
Loop

End With
End Sub

vivka · #2 08-17-2023, 01:24 PM

Hi, try this:

Code:

Sub FindYellowText()

Dim oSel As range
Dim oResponse As Document

    Set sel = ActiveDocument.range
    Set oResponse = Documents.Add
    
    With sel.Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .text = ""
        .MatchWildcards = False
        .Forward = True
        .Wrap = wdFindStop
        .Font.ColorIndex = wdYellow
        .Execute
        Do Until Not .found
            If sel.Font.ColorIndex = wdYellow Then
                sel.Cut
                With oResponse
                    selection.range.Paste
                    selection.MoveStart unit:=wdParagraph
                    selection.TypeParagraph
                End With
            End If
            .Execute
        Loop
    End With
End Sub

Onjai · #3 08-17-2023, 01:37 PM

Vivka,
Worked like a charm.
Thank you.
Cheers
Onjai

vivka · #4 08-17-2023, 09:51 PM

Onjai, my pleasure!

Onjai · #5 08-21-2023, 06:08 AM

Trying to loop through multiple docs in a folder, cut out green colored text, paste green text to new doc, save both docs in same folder. Code crashes on .Activate. Set statement is empty. Not sure why?

Code:

Sub FindGreenText()
Application.ScreenUpdating = False
Dim oSel As Range
Dim oResponse As Document
Dim oDoc As Document
Dim strDocName As String, strPath As String, strFile As String, strFolder As String

strFolder = "<folder location with doc files>"
strFile = Dir(strFolder & "\*.docx", vbNormal)

Set oDoc = Documents.Open(FileName:=strFolder & " \ " & strFile, AddToRecentFiles:=False, Visible:=True)

While strFile <> ""
    oDoc.Activate 'code stops here with empty set statement
    'DoEvents
    strDocName = Left(oDoc.Name, InStrRev(oDoc.Name, Chr(46)) - 1)
    strDocName = strDocName & "_response.docx"
    strPath = oDoc.Path & Chr(92)
    
    Set sel = ActiveDocument.Range
    Set oResponse = Documents.Add
        With sel.Find
            .ClearFormatting
            .Replacement.ClearFormatting
            .Text = ""
            .MatchWildcards = False
            .Forward = True
            .Wrap = wdFindStop
            .Font.ColorIndex = wdGreen
            .Execute
            Do Until Not .Found
                If sel.Font.ColorIndex = wdGreen Then
                    sel.Cut
                    With oResponse
                        Selection.Range.Paste
                        Selection.MoveStart unit:=wdParagraph
                        Selection.TypeParagraph
                    End With
                End If
                .Execute
            Loop
        End With
    oDoc.SaveAs2
    oResponse.SaveAs2 strPath & strDocName
    oDoc.Close
    oResponse.Close
    strFile = Dir()
Wend
Application.ScreenUpdating = True
MsgBox "Lucy, I'm home!"
End Sub

vivka · #6 08-21-2023, 07:17 AM

Hi! What I've noticed at once:
1. There are unnedeed spaces before & after the backslash in:
strFolder & " \ " & strFile
2. Use either sel or oSel, not both.

Onjai · #7 08-21-2023, 07:48 AM

ahh, that was it!

Now for a very interesting twist.... code works for wdYellow text and not for wdGreen text. I tried this several times and cannot understand why.

Anyone have a suggestion or thought?

vivka · #8 08-21-2023, 09:40 AM

Your code does work for WdGreen! The problem is your green font isn't actually the vba WdGreen,
although Word sets it as green. The vba green & the Word green have the same value (11) but are different colors!
Check for yourself using RGB codes: the genuine (vba) WdGreen is R=0, G=128, B=0 but your Word green is anything else.
It's strange, but the Word's Find-Replace dialogue recognizes the Word's green, set using the Find-Replace Format Font dialogue,
but doesn't recognize the vba WdGreen, while the vba / macro code recognizes the vba WdGreen but is blind to the Word Green.

To make the macro work for your "green", select any part of the colored text & use
msgbox selection.Font.ColorIndex
to get the code of your color. Then replace WdGreen in Find with the obtained code.

Onjai · #9 08-21-2023, 12:15 PM

The code works for other colors, not green.
The only way I was able to fix this was to:
msgbox Selection.Font.Color
It returned 5287936.
Changed the Find to:
.Font.Color = 5287936

Works!
Not sure why it is like this.
Thank you Vivka!

vivka · #10 08-21-2023, 02:31 PM

You are most welcome!

Onjai · #11 08-22-2023, 07:42 AM

Posting working code.

Code:

Sub FindGreenText()
       'speed up procedure
Application.ScreenUpdating = False
Dim sel As Range
Dim oResponse As Document
Dim oDoc As Document
Dim strDocName As String, strPath As String, strFile As String, strFolder As String
    'point to location of files
strFolder = "<folder with .docx files>"
strFile = Dir(strFolder & "\*.docx", vbNormal)
    'process each .docx file in folder
While strFile <> ""
    Set oDoc = Documents.Open(FileName:=strFolder & "\" & strFile, AddToRecentFiles:=False, Visible:=True)
    oDoc.Activate
    'name the .docx file with a new name for responses
    strDocName = Left(oDoc.Name, InStrRev(oDoc.Name, Chr(46)) - 1)
    strDocName = strDocName & "_response.docx"
    'sets the path to save new .docx file based on location of original .docx file(oDoc)
    strPath = oDoc.Path & Chr(92)
    
    Set sel = ActiveDocument.Range
    Set oResponse = Documents.Add
        With sel.Find
            .ClearFormatting
            .Replacement.ClearFormatting
            .Text = ""
            .MatchWildcards = False
            .Forward = True
            .Wrap = wdFindStop
            'finds green colored text
            .Font.Color = 5287936
            .Execute
            Do Until Not .Found
                If sel.Font.Color = 5287936 Then
                    sel.Cut
                    'pastes green text to new .docx
                    With oResponse
                        Selection.Range.Paste
                        Selection.MoveStart unit:=wdParagraph
                        Selection.TypeParagraph
                    End With
                End If
                .Execute
            Loop
        End With
    oDoc.SaveAs2
    oResponse.SaveAs2 strPath & strDocName
    oDoc.Close
    oResponse.Close
    strFile = Dir()
Wend
Application.ScreenUpdating = True
MsgBox "Lucy, I'm home!"
End Sub

Similar Threads
Thread	Thread Starter	Forum	Replies	Last Post
Copy selected text from one document and paste to new document in same position on the page	gasparik	Word VBA	1	05-11-2020 05:41 AM
Why do pages 10-24 disappear when I type in more text on page 2 or paste new text into the document?	RET	Word	1	05-02-2016 07:28 PM
colored background to text	userman	Word	2	09-26-2012 01:52 AM
not showing colored text from external emails	MasterGator	Outlook	0	01-31-2012 02:20 PM
Making text boxes with colored bar at the top	daviddoria	PowerPoint	0	08-30-2009 03:19 PM