Detect words in Word VBA that contain '-' in them

Viewed 606

I'm using this code to loop through all words in a document and find out if any of them contains said string and copy them to another, file but word seems to to cut the words in the middle in case there is a '-' character. Example

        For Each sentence In x.StoryRanges
        For Each w In sentence.Words
            If InStr(1, w, "asdf") = 1 Then
               objDoc.worksheets(1).Cells(i, 1).Value = w
  -continue code

it catches and copies the word "asdfaq-123" only as "asdfaq", Is there a way to copy until it hits '.' or ' '(space) or ')' , ']' etc..

Thank you!

3 Answers

Try something based on the code below, which uses a wildcard Find to locate the strings of interest.

Superficially, one would expect to be able simply to loop through the document’s StoryRanges as you're apparently trying to do. However, the StoryRanges object doesn't work reliably with Find/Replace for headers, footers, & shapes – Find/Replace on a StoryRange with multiple header, footer, & shape members only ever seems to look at the first member. Hence the apparent circumlocution in the code.

Dim r As Long

Sub Demo()
Application.ScreenUpdating = False
Dim Rng As Range, Sctn As Section, Shp As Shape, HdFt As HeaderFooter
With ActiveDocument
  For Each Rng In .StoryRanges
    Call FndRep(Rng)
    For Each Shp In Rng.ShapeRange
      With Shp
        If Not .TextFrame Is Nothing Then
          Call FndRep(.TextFrame.TextRange)
        End If
      End With
    Next
  Next
  For Each Sctn In .Sections
    For Each HdFt In Sctn.Headers
      With HdFt
        If .Exists = True Then
          If .LinkToPrevious = False Then
            Call FndRep(HdFt.Range)
            For Each Shp In HdFt.Shapes
              With Shp
                If Not .TextFrame Is Nothing Then
                  Call FndRep(.TextFrame.TextRange)
                End If
              End With
            Next
          End If
        End If
      End With
    Next
    For Each HdFt In Sctn.Footers
      With HdFt
        If .Exists = True Then
          If .LinkToPrevious = False Then
            Call FndRep(HdFt.Range)
            For Each Shp In HdFt.Shapes
              With Shp
                If Not .TextFrame Is Nothing Then
                  Call FndRep(.TextFrame.TextRange)
                End If
              End With
            Next
          End If
        End If
      End With
    Next
  Next
End With
Application.ScreenUpdating = True
End Sub

Sub FndRep(Rng As Range)
With Rng
  With .Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = "<asdf*>"
    .Replacement.Text = ""
    .Format = False
    .Forward = True
    .Wrap = wdFindStop
    .MatchWildcards = True
  End With
  Do While .Find.Execute
    If .Characters.Last.Next = "-" Then .MoveEnd wdWord, 2
    r = r + 1
    objDoc.worksheets(1).Cells(r, 1).Value = .Text
    .Collapse wdCollapseEnd
  Loop
End With
End Sub

Is this what you are trying?

Set a reference to Microsoft VBScript Regualr Expressions x.x library

Option Explicit

Sub Sample()
    Dim myRegExp As RegExp
    Dim myMatches As MatchCollection
    Dim myMatch As Match

    Set myRegExp = New RegExp

    With myRegExp
        .Global = True
        .Pattern = "([a-zA-Z0-9]+-[a-zA-Z0-9]+)"

        Set myMatches = myRegExp.Execute(ActiveDocument.Range.Text)

        For Each myMatch In myMatches
            Debug.Print myMatch.Value
        Next
    End With
End Sub

Explanation:

([a-zA-Z0-9]+-[a-zA-Z0-9]+)

(...)        - Isolate Full match
[a-zA-Z]     - Matches any characters between (Including) a-z or A-Z. 
[0-9]        - Matches any characters between (Including) 0 or 9. 
+ Quantifier - Matches between one and unlimited times

In Action:

enter image description here

Tip:

I usually use Online regex tester to test my regex patterns.

I've ended up replacing the '-'s with a temp string so Word will detect it as a single word, and after the words were copied I've replaced the temp string back to "-".

        With x.Content.Find ' replaces '-'s with "rplcmltr"
        .ClearFormatting
        .Text = "-"
        .Replacement.ClearFormatting
        .Replacement.Text = "rplcmltr"
        .Execute Replace:=wdReplaceAll, Forward:=True, _
        Wrap:=wdFindContinue
    End With
Related