Find the content by color and copy it

bblelli · #1 03-04-2023, 08:04 PM

Dears,

I'm trying to create a macro that search for every text written in purple color and
everytime the macro finds this red text, the macro should copy this paragrah and the next one.

Let's suppose that I have the following text:

Add Value. Something many self-made wealthy people have in common is that they are valuable in specific ways. ...
Tax Yourself. The concept of saving money is not a new one. ...
Create a Plan and Follow It. ...
Invest. ...
Start a Business. ...
Be Grateful. ...
Develop Patience. ...

In this case, I would like to have another word document with the following content:
Tax Yourself. The concept of saving money is not a new one. ...
Create a Plan and Follow It. ...

How can I do that?

I'm trying to work with the following code, wchich is working and returning just the first line, not the second one.

Code:

Option Explicit

Sub CopyRedText()
    Dim oTarget As Document
    Dim oDoc As Document
    Dim oRng As Range, oEnd As Range, oOriginal As Range
    Set oDoc = ActiveDocument
    Set oTarget = Documents.Add
    Set oRng = oDoc.Range
    Set oOriginal = oDoc.Range
    Set oEnd = oTarget.Range
    oOriginal.Collapse 0
    With oRng.Find
    .Font.Color = RGB(112, 48, 160)
    
        Do While .Execute
            If oRng.Start >= oOriginal.Start Then GoTo lbl_Exit
            oEnd.Collapse 0
            

            oEnd.FormattedText = oRng.FormattedText

            
            oEnd.Collapse 0
            oEnd.Collapse 1
            oEnd.InsertParagraphAfter
            oEnd.End = oTarget.Range.End
            'oRng.Text = ""
            'oRng.Collapse 0
        Loop
    End With
    oTarget.Activate
lbl_Exit:
    Exit Sub
End Sub

Thanks

gmayor · #2 03-04-2023, 09:41 PM

The text in your pasted extract is not RGB(112,48,160) You need to check that - I recommend Color Cop -, however

Code:

Sub Macro1()
Dim oTarget As Document
Dim oDoc As Document
Dim oRng As Range, oEnd As Range
    Set oDoc = ActiveDocument
    Set oTarget = Documents.Add
    Set oRng = oDoc.Range

    With oRng.Find
        .Font.Color = RGB(128, 0, 128)
        .Text = ""
        Do While .Execute
            oRng.MoveEndUntil Chr(13)
            oRng.End = oRng.End + 1
            oRng.MoveEndUntil Chr(13)

            Set oEnd = oTarget.Range
            oEnd.Collapse 0
            oEnd.FormattedText = oRng.FormattedText
            oEnd.Collapse 0
            oEnd.InsertParagraphAfter
            oRng.Collapse 0
        Loop
    End With
    oTarget.Activate
lbl_Exit:
    Set oTarget = Nothing
    Set oDoc = Nothing
    Set oRng = Nothing
    Set oEnd = Nothing
    Exit Sub
End Sub

works for your example.

bblelli · #3 03-05-2023, 05:55 AM

It's working. Thank you so much!

Btw, What if a want to copy the content from the left cell, instead of the next row, how can I do that?
And, how can I add the page number that this content was extracted?

Thanks

gmayor · #4 03-05-2023, 09:31 PM

Left cell? Your question (and code) didn't mention tables. You would need to supply a sample document so that we can see what you are working with.
The page number is simpler

Code:

 Do While .Execute
            oRng.MoveEndUntil Chr(13)
            oRng.End = oRng.End + 1
            oRng.MoveEndUntil Chr(13)

            Set oEnd = oTarget.Range
            oEnd.Collapse 0
            oEnd.FormattedText = oRng.FormattedText
            oEnd.Collapse 0
            oEnd.Text = Chr(32) & "Page " & oRng.Information(wdActiveEndPageNumber)
            oEnd.Collapse 0
            oEnd.InsertParagraphAfter
            oRng.Collapse 0
        Loop

bblelli · #5 03-06-2023, 08:40 AM

Yes, the fact is that I mixed 2 questions in just one.

Please, find attached a sample of how I would like to work with cells...

I would like to check all the cells number 4, and if the text is equal do "d", the system must return the text of the cell number 3

So, in this case, I would like to get somethine like this:
d | c | Page 1

How can I do that?

bblelli · #6 03-07-2023, 11:11 AM

This is what I'm trying to do.
Any help is very welcoming!

Code:

Sub Demo()
'Application.ScreenUpdating = False
Dim r As Long, c As Long
Dim l As Integer
Dim theNewRow As Row
Dim oSec As Section
Dim newPage As Section


'Cria um novo documento Word
Set oDoc = ActiveDocument
Set oTarget = Documents.Add
Set newPage = ActiveDocument.Sections.Add

'Cria uma nova tabela Word
oTarget.Tables.Add Range:=Selection.Range, NumRows:=2, NumColumns:= _
4, DefaultTableBehavior:=wdWord9TableBehavior, AutoFitBehavior:= _
wdAutoFitFixed

'Formata esta nova tabela

With ActiveDocument.Tables(1)
    .Cell(1, 1).Range.Text = "ISARP"
    .Cell(1, 2).Range.Text = "ITEM"
    .Cell(1, 3).Range.Text = "SESSION"
    .Cell(1, 4).Range.Text = "PAGE"
    
    .Columns(1).SetWidth ColumnWidth:=CentimetersToPoints(2.5), rulerstyle:=wdAdjustFirstColumn
    .Columns(2).SetWidth ColumnWidth:=CentimetersToPoints(8.1), rulerstyle:=wdAdjustFirstColumn
    .Columns(3).SetWidth ColumnWidth:=CentimetersToPoints(2.7), rulerstyle:=wdAdjustFirstColumn
    .Columns(4).SetWidth ColumnWidth:=CentimetersToPoints(1.7), rulerstyle:=wdAdjustFirstColumn
End With


l = 2

oDoc.Activate
With ActiveDocument.Range
  With .Find
    .Text = "IOSA"
    .Execute
  End With



Do While .Find.Found
    If .Information(wdWithInTable) = True Then
    nTabelasOrigem = ActiveDocument.Range(0, Selection.Tables(1).Range.End).Tables.Count
    Set theNewRow = ActiveDocument.Tables(nTabelasOrigem).Rows.Add
      t = ActiveDocument.Range(0, Selection.Tables(nTabelasOrigem).Range.End).Tables.Count
      r = .Cells(1).RowIndex
      c = .Cells(1).ColumnIndex
      d = oDoc.Tables(t).Cell(r, c).Range.Information(wdActiveEndPageNumber)
      e = oDoc.Range.GoTo(What:=wdGoToPage, Name:=d).Sections.First.Headers(wdHeaderFooterPrimary).Range.Text

    oTarget.Activate
      a = oDoc.Tables(t).Cell(r, c).Range.Text
      b = oDoc.Tables(t).Cell(r, c - 1).Range.Text

      With ActiveDocument.Tables(1).Rows(l)
        .Cells(1).Range.Text = a
        .Cells(2).Range.Text = b
        .Cells(3).Range.Text = e
        .Cells(4).Range.Text = d
      End With
      
l = l + 1

    End If
    .Collapse wdCollapseEnd
    .Find.Execute
  Loop
End With
'Application.ScreenUpdating = True
End Sub

Similar Threads
Thread	Thread Starter	Forum	Replies	Last Post
copy/paste changes text color !!!	yvessr	Word	8	07-16-2019 02:44 PM
Content control font color	rkferguson	Word VBA	1	12-18-2018 05:06 AM
Changing color of instructional text in a content control box	Document Specialist	Word	2	08-17-2018 05:25 AM
Text Field [content control] - Default text color vs Filled Text color	jackcoletti	Word	3	02-01-2017 08:10 AM
Macro that can find phrase and then find another and copy	jperez84	Word VBA	10	09-19-2012 04:48 PM