MS Word Macro for Find/Copy/Paste

[montanaheather]

Hello,

I am reading through pages of transcripts in MS word. I am looking for key words that I need for research purposes. I would like to copy and paste not only the key word, but text before and after the keyword to give the key word context in my research notes. The problem I have is that the amount of text before and after each key word may should be able to change as I run each search. So, instead of search for a keyword and always finding, copying, and pasting the keyword and 10 words before and after it, I would like the ability to tell the macro how many words to copy and paste before and after the key word each time the search is run. Below is a list of what I want the macro to do, along with what I have so far (sorry that it's not much!).

Your help is MUCH appreciated!

To do:
1. find a key word that I input each time I run the search. I would like to choose a different key word each time the macro is run.
2. define the number of words (not just characters) both before and after the key word for the macro to copy and paste, along with the keyword, to give the search results context.
3. I would like the option to change the number of words each time the macro is run. For example, I would like to choose 5 words before and 10 words after on the first search, 8 words before, 5 words after on the second search, etc.
4. I need the macro to find all instances of the keyword, and not just the first instance, before ending. So, running the macro once should return all words that match the keyword, not just the first one found.
5. I would like to use some sort of wild card to find "similar" words, in case the word is not a 100% perfect match.
6. Search word should not be case sensitive.
7. I would like the copy/paste to happen in a new document.
8. If at all possible, I would like to "skip" a copy and paste if a keyword found is not what I want (not every keyword match would be something I would like to copy and paste for later).

Code, both what I wrote and strings I tried to piece together from a replace macro I found online. I wanted to tweak the replace code, but I don't know how (sorry this is so bad...I am new at macros!):

'variables
Dim searchTerm As String
Dim searchTermStringLength As Integer
Dim numberCharacterToSearch As Integer
Dim MyRange As Object

'user asked for search term to begin search subroutine
searchTerm = InputBox("Enter your search terms, Maria Cancro! Then, sit back, relax, and let this macro do some heavy lifting. It's okay - it works out!")
numberCharacterToSearch = InputBox("Enter the number of chaaracters before and after your search term to find, copy, and paste, along with your search term.")
searchTermStringLength = Len(searchTerm)

'the search begins using the searchTerm string entered by user
If Len(searchTerm) <> 0 Then
With Selection
.HomeKey Unit:=wdStory
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = "(*)(searchTerm)(*)"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchAllWordForms = False
.MatchSoundsLike = False
.MatchWildcards = True
.Execute Replace:=wdReplaceAll
End With
End With
' user canceled
Exit Sub
End If
End Sub

 

[Macropod]

Hi montanaheather,

Try:

Sub Demo()
Dim SearchTerm As String, WordsAfter As Long, WordsBefore As Long, i As Long
Dim Rng As Range, Doc As Document, RngOut As Range
SearchTerm = InputBox("Enter your search terms, Maria Cancro!" & vbCr & _
  "Then, sit back, relax, and let this macro do some heavy lifting." & vbCr & _
  vbCr & "It's okay - it works out!")
SearchTerm = LCase(Trim(SearchTerm))
If Len(SearchTerm) = 0 Then Exit Sub
WordsBefore = InputBox("Enter the number of words before your search term to find.")
WordsAfter = InputBox("Enter the number of words after your search term to find.")
With ActiveDocument.Range
  With .Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = SearchTerm
    .Replacement.Text = ""
    .Forward = True
    .Wrap = wdFindStop
    .Format = False
    .MatchCase = False
    .MatchWholeWord = False
    .MatchAllWordForms = False
    .MatchSoundsLike = False
    .MatchWildcards = False
    .Execute
  End With
  If .Find.Found Then
    Set Doc = Documents.Add(Visible:=False)
    Do While .Find.Found
      Set Rng = .Duplicate
      With Rng
        .MoveStart wdWord, -WordsBefore
        .MoveEnd wdWord, WordsAfter + 2
        .Select
        If MsgBox(.Text, vbYesNo, "Copy this block?") = vbYes Then
          .Copy
          With Doc
            .Range.InsertAfter vbCr
            Set RngOut = .Characters.Last
            RngOut.Paste
          End With
        End If
      End With
      .Collapse wdCollapseEnd
      .Find.Execute
    Loop
    Doc.Activate
    ActiveWindow.Visible = True
  End If
End With
End Sub

 

[montanaheather]

This is great, thank you!

 

[montanaheather]

Hello, again,

Thank you for the help before. It's fun to learn more about Word macros!

The macro to find search terms is working. I am trying to learn how to find and highlight the search terms in the new document (where the search results are pasted from the original document). I have the code below, but it's not highlighting anything in either document. I feel like this is a super simple fix, but I cannot figure it out. Any help is MUCH appreciated!!!

Thanks!

CODE (the green bolded text is where I think the problem is...but I am not sure...)

Sub GASBWordSearch()
Dim SearchTerm As String
Dim WordsAfter As Long
Dim WordsBefore As Long
Dim i As Long
Dim Rng As Range
Dim Doc As Document
Dim RngOut As Range

On Error GoTo ErrHandler:

SearchTerm = InputBox("Enter your search terms, Maria Cancro!" & vbCr & _
"Then, sit back, relax, and let this macro do some heavy lifting." & vbCr & _
vbCr & "It's okay - it works out!")
SearchTerm = LCase(Trim(SearchTerm))
If Len(SearchTerm) = 0 Then Exit Sub
WordsBefore = InputBox("Enter the number of words before your search term to find.")
WordsAfter = InputBox("Enter the number of words after your search term to find.")
With ActiveDocument.Range
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = SearchTerm
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchAllWordForms = False
.MatchSoundsLike = False
.MatchWildcards = False
.Execute
End With
If .Find.Found Then
Set Doc = Documents.Add(Visible:=True)
Do While .Find.Found
Set Rng = .Duplicate
With Rng
.MoveStart wdWord, -WordsBefore
.MoveEnd wdWord, WordsAfter + 1
.Select
If MsgBox(.Text, vbYesNo, "Copy this block?") = vbYes Then
.Copy
With Doc
.Range.InsertAfter vbCr
Set RngOut = .Characters.Last
RngOut.Paste
' RngOut.HighlightColorIndex = wdTurquoise
End With
End If
End With
.Collapse wdCollapseEnd
.Find.Execute
Loop
Doc.Activate
ActiveWindow.Visible = True
End If
End With

' HighlightSearchTerm Macro
' Highlights your search terms IN THE NEW DOCUMENT ONLY so you can easily see what you searched for later
Doc.Activate
Selection.Find.ClearFormatting
With Selection.Find
.Text = SearchTerm
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = True
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Doc.Activate
Exit Sub
'exits sub if there was a data entry error above
ErrHandler:
' error handling code
If MsgBox("Oops! It seems there was an error in your request. Please run your search again. Hit Ctrl+M+C and give it another go!", vbOKOnly, "Search Error") = vbOK Then
Exit Sub
End If
End Sub

 

[Macropod]

Hi montanaheather,

After the final 'End With' in the code I gave you, insert:

With Doc.Range.Find
  .ClearFormatting
  .Replacement.ClearFormatting
  .Text = SearchTerm
  .Replacement.Text = "^&"
  .Replacement.Highlight = True
  .Forward = True
  .Wrap = wdFindStop
  .Format = True
  .MatchCase = False
  .MatchWholeWord = False
  .MatchAllWordForms = False
  .MatchSoundsLike = False
  .MatchWildcards = False
  .Execute Replace:=wdReplaceAll
End With

PS: When posting code, please use code tags.

 

[Legacy 103420]

New version of the MS Word Find/Copy/Paste script

I have created a new version of the script which displays the page numbers of the findings and links them to the original document. Feel free to test it and give feedback on how it works

The name of the macro is CopyKeywordPlusContext().

Also there is a second makro included with which you can summarize all highlighted text into a new document. It partly uses the same routines. It's called CopyHighlightedTextInNewDocument.

Code:

Sub GoToAPageAndLine()'
' Makro created on 22.01.2013
'
    Dim TargetDocName, SearchTerm, MyString As String, TargetDoc As Document
    Dim PosDelimiter, PosMakroButton, Page, Line
    'Read Private Field which contains The Document Name
    MyString = Mid$(Selection.Fields(2).Code, 10)
    MyString = Left$(MyString, Len(MyString) - 1)
    PosDelimiter = InStr(MyString, "|")
    TargetDocName = Left$(MyString, PosDelimiter - 1)
    SearchTerm = Mid$(MyString, PosDelimiter + 1)
    'MsgBox TargetDocName
    'Read the MakroButton Text which contains Page Number and Line
    MyString = Mid$(Selection.Fields(1).Code, 1)
    PosMakroButton = InStr(MyString, "MACROBUTTON")
    MyString = Mid$(MyString, PosMakroButton + 32)
    PosDelimiter = InStr(MyString, ", ")
    Page = Left$(MyString, PosDelimiter - 1)
    Line = Mid$(MyString, PosDelimiter + 4)
    'MsgBox Page
    'MsgBox Line
    On Error GoTo Errhandler
    Set TargetDoc = Documents(TargetDocName)
    TargetDoc.Activate
    Selection.GoTo What:=wdGoToPage, Which:=wdGoToAbsolute, Count:=Page, Name:=""
    If Line - 1 > 0 Then
        Selection.GoTo What:=wdGoToLine, Which:=wdGoToRelative, Count:=Line - 1, Name:=""
    End If
    If SearchTerm <> "" Then
        Selection.Find.ClearFormatting
        With Selection.Find
            .Text = SearchTerm
            .Replacement.Text = ""
            .Forward = True
            .Wrap = wdFindContinue
            .Format = False
            .MatchCase = False
            .MatchWholeWord = False
            .MatchWildcards = False
            .MatchSoundsLike = False
            .MatchAllWordForms = False
        End With
        Selection.Find.Execute
    End If
Errhandler:
    Select Case Err
        Case 4160: 'Error 4160 = Bad file name
            MsgBox "The file """ & TargetDocName & """ isn't open. Please open the file first."
    End Select
End Sub
Sub macrobutton(Page, Line As Integer, Filename, Searchterm As String)
'
' Makro created on 22.01.2013
'
    Dim oField As Field, MyRange As Range
    Set MyRange = Selection.Range
    Set oField = Selection.Fields.Add(Range:=MyRange, Type:=wdFieldEmpty, Text:= _
        "MACROBUTTON GoToAPageAndLine S. " & Page & ", Z. " & Line & "", PreserveFormatting:= _
        False)
    Set oRange = ActiveDocument.Range(oField.Code.Start + 1, oField.Code.Start + 1)
    ActiveDocument.Fields.Add Range:=oRange, Type:=wdFieldPrivate, Text:="" & Filename & "|" & Searchterm, PreserveFormatting:=False
End Sub
Sub CopyHighlightedTextInNewDocument()
'
' Makro created on 22.01.2013
'
    ActiveDocument.Range(0, 0).Select
    With Selection
        .Find.ClearFormatting
        .Find.Highlight = True
        With .Find
            .Replacement.ClearFormatting
            .Text = ""
            .Replacement.Text = ""
            .Forward = True
            .Wrap = wdFindContinue
            .Format = True
            .MatchCase = False
            .MatchWholeWord = False
            .MatchWildcards = False
            .MatchSoundsLike = False
            .MatchAllWordForms = False
        End With
        Set CurrentDoc = ActiveDocument
        Set NewDoc = Documents.Add(Visible:=False)
        NewDoc.Content.InsertAfter "Summary of the highlighted text in " & """" & CurrentDoc.Name & """"
        NewDoc.Content.Font.Bold = True
        NewDoc.Content.InsertParagraphAfter
        NewDoc.Content.InsertParagraphAfter
        .Find.Execute
        Dim PageNumber, LineNumber As Integer
        Do While .Find.Found
            .Select
            Selection.Copy
            PageNumber = .Information(wdActiveEndPageNumber)
            LineNumber = .Information(wdFirstCharacterLineNumber)
            NewDoc.Activate
            With Selection
              .EndKey Unit:=wdStory
              .Font.Bold = True
              .Font.Underline = True
              .Font.ColorIndex = wdDarkBlue
              Call macrobutton(PageNumber, LineNumber, CurrentDoc.Name, "")
              .Font.Bold = True
              .Font.Underline = False
              .Font.ColorIndex = wdBlack
              '.InsertAfter "S. " & PageNumber
              '.InsertAfter ", Z. " & LineNumber
              .TypeText "______________________________________________________________" & vbCr
              .InsertParagraphAfter
              .MoveDown Unit:=wdLine, Count:=1, Extend:=wdMove
              .Paste
              .InsertParagraphAfter
              .InsertParagraphAfter
              .MoveDown Unit:=wdLine, Count:=2, Extend:=wdMove
            End With
            CurrentDoc.Activate
            .Find.Execute
        Loop
    End With
    NewDoc.Activate
    Options.ButtonFieldClicks = 1
    Selection.HomeKey Unit:=wdStory
    ActiveWindow.Visible = True
End Sub
Sub CopyKeywordPlusContext()
'
' Makro created on 22.01.2013
'
    Dim SearchTerm As String, WordsAfter As Long, WordsBefore As Long, i As Long
    Dim Rng As Range, Doc As Document, RngOut As Range
    SearchTerm = InputBox("Enter your search terms, Maria Cancro!" & vbCr & _
      "Then, sit back, relax, and let this macro do some heavy lifting." & vbCr & _
      vbCr & "It's okay - it works out!")
    SearchTerm = LCase(Trim(SearchTerm))
    If Len(SearchTerm) = 0 Then Exit Sub
    WordsBefore = InputBox("Enter the number of words before your search term to find.")
    WordsAfter = InputBox("Enter the number of words after your search term to find.")
    ActiveDocument.Range(0, 0).Select
    With Selection
      With .Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .Text = SearchTerm
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindStop
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchAllWordForms = False
        .MatchSoundsLike = False
        .MatchWildcards = False
        .Execute
      End With
      If .Find.Found Then
        Set CurrentDoc = ActiveDocument
        Set Doc = Documents.Add(Visible:=False)
        Doc.Content.InsertAfter "Search results for """ & SearchTerm & """ + context in " & """" & CurrentDoc.Name & """"
        Doc.Content.Font.Bold = True
        Doc.Content.InsertParagraphAfter
        Doc.Content.InsertParagraphAfter
        Dim CheckAuto As Integer
        CheckAuto = MsgBox("Should all findings be copied automatically ('yes') or do you want to check each occurence manually ('no') ?", vbYesNo, "Automatically oder manually?")
        Dim CopyThis As Boolean
        Do While .Find.Found
          CopyThis = False
          Set Rng = .Range.Duplicate
          With Rng
            .Select
            Dim SelectionStart, SelectionEnd
            SelectionStart = Selection.Range.Start
            SelectionEnd = Selection.Range.End
            ActiveDocument.Range(SelectionStart, SelectionStart).Select
            Dim PageNumber, LineNumber As Integer
            PageNumber = Selection.Information(wdActiveEndPageNumber)
            LineNumber = Selection.Information(wdFirstCharacterLineNumber)
            .MoveStart wdWord, -WordsBefore
            .MoveEnd wdWord, WordsAfter + 2
            .Select
            Selection.MoveStart Unit:=wdLine, Count:=-1 'Comment this out if you 
            Selection.MoveEnd Unit:=wdLine, Count:=1    '                        don't want the selection to be extended to the start / end of line
            If CheckAuto = vbYes Then
                CopyThis = True
            Else
                Dim Check As Integer
                Check = MsgBox(.Text, vbYesNoCancel, "Copy this block?")
                If Check = vbCancel Then
                    Exit Do
                ElseIf Check = vbYes Then
                    CopyThis = True
                End If
            End If
            If CopyThis = True Then
              Selection.Copy
              Doc.Activate
              With Selection
                  .EndKey Unit:=wdStory
                  .Font.Bold = True
                  .Font.Underline = True
                  .Font.ColorIndex = wdDarkBlue
                  Call macrobutton(PageNumber, LineNumber, CurrentDoc.Name, SearchTerm)
                  .Font.Bold = True
                  .Font.Underline = False
                  .Font.ColorIndex = wdBlack
                  '.InsertAfter "S. " & PageNumber
                  '.InsertAfter ", Z. " & LineNumber
                  .TypeText "______________________________________________________________" & vbCr
                  .InsertParagraphAfter
                  .MoveDown Unit:=wdLine, Count:=1, Extend:=wdMove
                  .Paste
                  .InsertParagraphAfter
                  .InsertParagraphAfter
                  .MoveDown Unit:=wdLine, Count:=2, Extend:=wdMove
              End With
              CurrentDoc.Activate
            End If
          End With
          .Collapse wdCollapseEnd
          .Find.Execute
        Loop
        Doc.Activate
      End If
    End With
    With Doc.Range.Find
      .ClearFormatting
      .Replacement.ClearFormatting
      .Text = SearchTerm
      .Replacement.Text = "^&"
      .Replacement.Highlight = True
      .Forward = True
      .Wrap = wdFindStop
      .Format = True
      .MatchCase = False
      .MatchWholeWord = False
      .MatchAllWordForms = False
      .MatchSoundsLike = False
      .MatchWildcards = False
      .Execute Replace:=wdReplaceAll
    End With
    Options.ButtonFieldClicks = 1
    Selection.HomeKey Unit:=wdStory
    ActiveWindow.Visible = True
End Sub

 

[Mike55]

Re: New version of the MS Word Find/Copy/Paste script

Hello,

Tonmegub's Jan 23rd 2013 additions to Macropod's wonderful code sound like great improvements, but they don't seem to work for me. I'm very new to VBA (and this forum). I'm using Word 2003. Can anyone help?