Copy text in a document with anchor

Good morning!

I'm trying to develop a sub routine where I need to copy the next word whenever appears "Modelo:", example:

Modelo: OPTIFLUX 2100 C
The text I need to copy is "OPTIFLUX 2100 C", there is a tab between "Modelo:" and "OPTIFLUX 2100 C".

The code I develop is:

Code:

---

Sub Chipita_kok(W, V, Y, Z, x, New1)
Dim Modelo1 As String
 
    New1 = ""
    Modelo1 = ""
 
    W = Selection.Information(wdActiveEndPageNumber)
    Z = Selection.Information(wdVerticalPositionRelativeToPage)
 
    On Error Resume Next
 
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = "Modelo:"
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindStop
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute
    Selection.MoveRight Unit:=wdCharacter, Count:=1
    Selection.MoveRight Unit:=wdWord, Count:=1
    Selection.EndKey Unit:=wdLine, Extend:=wdExtend
    Selection.MoveLeft Unit:=wdCharacter, Count:=1, Extend:=wdExtend
    Selection.Copy
    Modelo1 = Selection
    V = Selection.Information(wdActiveEndPageNumber)
    If Left(Modelo1, 9) = "IFC 100 W" Or Left(Modelo1, 9) = "IFC 100 C" Or Left(Modelo1, 9) = "IFC 070 C" Or Left(Modelo1, 9) = "IFC 070 F" Or Left(Modelo1, 9) = "IFC 050 C" Or Left(Modelo1, 9) = "IFC 050 W" Or Left(Modelo1, 13) = "Optiflux 2000" Or Left(Modelo1, 5) = "V/Ref" Or Left(Modelo1, 13) = "Optiflux 1000" Then
    Modelo1 = ""
    If V = "" Then GoTo Fomes
    Selection.EndKey Unit:=wdLine
    x = Selection.Information(wdVerticalPositionRelativeToPage)
    Y = Selection.Information(wdVerticalPositionRelativeToPage)
 
    Else
    New1 = Modelo1
    End If
 
Fomes:
 
    Y = Selection.Information(wdVerticalPositionRelativeToPage)
    Selection.EndKey Unit:=wdLine
    'Selection.MoveDown Unit:=wdLine, Count:=5
 
End Sub

---

It becames more complex when I need to avoid some text just like "IFC 100 W", "IFC 100 C", "IFC 070 C", (...)

The state of the art for this routine is when appers a table just like:

Qde	Diâmetro/Flanges
5	DN25 PN40
1	DN32 PN40
8	DN40 PN40
2	DN50 PN40
3	DN65 PN16
6	DN80 PN40
1	DN100 PN16

the variable Modelo1 must be is equal to "OPTIFLUX 2100 C" as many the "Qde" times, for this table 7 times. Note: the tables appears sometimes.

Is this possible in VBA?

Any help will be much appreciated!

Best regards

Nuno

The part of your question

Quote:

---

I'm trying to develop a sub routine where I need to copy the next word whenever appears "Modelo:", example:

Modelo: OPTIFLUX 2100 C
The text I need to copy is "OPTIFLUX 2100 C", there is a tab between "Modelo:" and "OPTIFLUX 2100 C".

---

is fairly straightforward. The rest of your question is incomprehensible.
For a start you have asked for the next 'word' after "Modelo:" and yet your example has three words and there is no context in relation to what else is in the document or how it is formatted?
How for example would a macro know when the required string ended? The next word would be OPTIFLUX which is easy, but how is the macro to know that you want 2100 or 2100 C also?

You have a list of things to exclude, but what do you want to do with those words that are not excluded when they are found?

Hello gmayor,

Sorry if I wasn't clear enought!

Yes you are right, in the example I gave "Optiflux 2100 C" it is three words in fact. What I want to do is to copy to the end of the line next to "Modelo:", it could be one word or more, this is what this routine do

Code:

---

Selection.MoveRight Unit:=wdCharacter, Count:=1   
Selection.MoveRight Unit:=wdWord, Count:=1
Selection.EndKey Unit:=wdLine, Extend:=wdExtend
Selection.MoveLeft Unit:=wdCharacter, Count:=1, Extend:=wdExtend
Selection.Copy    
Modelo1 = Selection

---

Quote:

---

You have a list of things to exclude, but what do you want to do with those words that are not excluded when they are found?

---

When the selection is different of "IFC 100 W", "IFC 100 C", "IFC 070 C", (...) a variable must have the same value of the selection.


Can I help to clarify other questions?

Regards

You still haven't said what you want to do with these found items, however the basic code to find them (omitting those you listed) is as follows, assuming that by 'Line' you mean 'Paragraph'

Code:

---

Sub Macro1()Dim oRng As Range
Const strFind As String = "Modelo:^t"
    Set oRng = ActiveDocument.Range
    With oRng.Find
        Do While .Execute(FindText:=strFind)
            oRng.Collapse 0
            oRng.End = oRng.Paragraphs(1).Range.End - 1
            If Not Left(oRng.Text, 9) = "IFC 100 W" Or _
              Not Left(oRng.Text, 9) = "IFC 100 C" Or _
              Not Left(oRng.Text, 9) = "IFC 070 C" Or _
              Not Left(oRng.Text, 9) = "IFC 070 F" Or _
              Not Left(oRng.Text, 9) = "IFC 050 C" Or _
              Not Left(oRng.Text, 9) = "IFC 050 W" Or _
              Not Left(oRng.Text, 13) = "Optiflux 2000" Or _
              Not Left(oRng.Text, 5) = "V/Ref" Or _
              Not Left(oRng.Text, 13) = "Optiflux 1000" Then
                'do what you want with oRng here e.g.
                MsgBox oRng.Text
            End If
            oRng.Collapse 0
        Loop
    End With
lbl_Exit:
    Set oRng = Nothing
    Exit Sub
End Sub

---

Quote:

---

Originally Posted by gmayor

You still haven't said what you want to do with these found items, however the basic code to find them (omitting those you listed) is as follows, assuming that by 'Line' you mean 'Paragraph'

---

The Objective is to put that found items in a Microsoft Office Spreadsheet 11.0 which is in a userform


Thank you gmayor!

The following will add the found items to an array and you can write that array to a worksheet as shown

Code:

---

Sub Macro1()
Dim arrList() As String
Dim oRng As Range
Dim xlApp As Object
Dim xlBook As Object
Dim NextRow As Integer, i As Integer
Const strFind As String = "Modelo:^t"
    Set oRng = ActiveDocument.Range
    ReDim arrList(0)
    With oRng.Find
        Do While .Execute(FindText:=strFind)
            oRng.Collapse 0
            oRng.End = oRng.Paragraphs(1).Range.End - 1
            If Not Left(oRng.Text, 9) = "IFC 100 W" Or _
              Not Left(oRng.Text, 9) = "IFC 100 C" Or _
              Not Left(oRng.Text, 9) = "IFC 070 C" Or _
              Not Left(oRng.Text, 9) = "IFC 070 F" Or _
              Not Left(oRng.Text, 9) = "IFC 050 C" Or _
              Not Left(oRng.Text, 9) = "IFC 050 W" Or _
              Not Left(oRng.Text, 13) = "Optiflux 2000" Or _
              Not Left(oRng.Text, 5) = "V/Ref" Or _
              Not Left(oRng.Text, 13) = "Optiflux 1000" Then
                ReDim Preserve arrList(UBound(arrList) + 1)
                arrList(UBound(arrList)) = oRng.Text
            End If
            oRng.Collapse 0
        Loop
    End With
    On Error Resume Next
    Set xlApp = GetObject(, "Excel.Application")
    If Err Then
        Set xlApp = CreateObject("Excel.Application")
    End If
    On Error GoTo 0
    Set xlBook = xlApp.Workbooks.Add
    xlBook.Sheets(1).Cells(1, 1).value = "Modelo"
    xlApp.Visible = True
    For i = 0 To UBound(arrList)
        NextRow = xlBook.Sheets(1).Range("A" & xlBook.Sheets(1).Rows.Count).End(-4162).Row + 1
        xlBook.Sheets(1).Cells(NextRow, 1).value = arrList(i)
    Next i
lbl_Exit:
    Set oRng = Nothing
    Set xlApp = Nothing
    Set xlBook = Nothing
    Exit Sub
End Sub

---

Sorry gmayor for the late reply, I was out of the country in vacations.

What I intend to do is to put those found words in a userform textbox.

Based on the last code you posted i developed the following code that works better for what I intend to do:

Code:

---

Sub Macro99()
Dim oRng As range
Const strFind As String = "Modelo:^t"
   
    Set oRng = ActiveDocument.range
    With oRng.Find
        Do While .Execute(FindText:=strFind)
            oRng.Collapse 0
            oRng.End = oRng.Paragraphs(1).range.End - 1
                       
            If Left(oRng.Text, 9) = "IFC 100 W" Or _
              Left(oRng.Text, 9) = "IFC 100 C" Or _
              Left(oRng.Text, 9) = "IFC 070 C" Or _
              Left(oRng.Text, 9) = "IFC 070 F" Or _
              Left(oRng.Text, 9) = "IFC 050 C" Or _
              Left(oRng.Text, 9) = "IFC 050 W" Or _
              Left(oRng.Text, 9) = "IFC 300 W" Or _
              Left(oRng.Text, 9) = "MAC 100" Or _
              Left(oRng.Text, 17) = "OPTISENS ODO 2000" Or _
              Left(oRng.Text, 13) = "Optiflux 2000" Or _
              Left(oRng.Text, 17) = "SMARTPAT ORP 1590" Or _
              Left(oRng.Text, 16) = "Waterflux 3000 F" Or _
              Left(oRng.Text, 13) = "Optiflux 1000" Or _
              Left(oRng.Text, 15) = "Optiflux 2000 F" Then
                GoTo 1
            End If
                  MsgBox oRng.Text
1:
          oRng.Collapse 0
        Loop
    End With
lbl_Exit:
    Set oRng = Nothing
    Exit Sub
End Sub

---

Just one more question: Could we find more than one word?