justcracked
02-18-2015, 12:11 PM
Good afternoon
I have been searching the internet for a macro which does the following:
Searches the document I have open for a phrase
Copies this phrase, highlights it together with the unhighlighted context (say 20 characters either side) and pastes into column 'A' of a 2 column table created in new word document
Copies the page number that the above selection is on and pastes that into column 'B' (same row as above) of the above table in the same new document
This would then be repeated throughout the document for each instance of the phrase (creating a new line in the table of the new document for each instance)
I have been able to find some macros which enables parts of the above and then I stumbled upon this beautiful macro below (Credit: Mario Cancro)
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
This lets me search for a word (via a prompt), specify how many characters before and after it to copy (via a prompt) and then pastes a highlighted version in a new document with a hyperlink to the occurrence in the original document. I wanted to maybe try and streamline this as follows if possible:
Instead of the first prompt asking which word I wanted to find; I would like it to use an excel spreadsheet (lets call it checklist) with a list of phrases on seperate lines in cloumn 'A' (example: nation wide) as a source
Instead of asking how many characters before and after: I would like it to be hard coded to be 20
Instead of asking if each occurrence is copied: I would like it to copy all occurrences
I don't know if this is possible, but was hoping that it was and would be grateful if someone could point me in the right direction, as I'm stumbling at getting the amendments to work.
Many thanks for looking at this post
Cheers
Pablo
I have been searching the internet for a macro which does the following:
Searches the document I have open for a phrase
Copies this phrase, highlights it together with the unhighlighted context (say 20 characters either side) and pastes into column 'A' of a 2 column table created in new word document
Copies the page number that the above selection is on and pastes that into column 'B' (same row as above) of the above table in the same new document
This would then be repeated throughout the document for each instance of the phrase (creating a new line in the table of the new document for each instance)
I have been able to find some macros which enables parts of the above and then I stumbled upon this beautiful macro below (Credit: Mario Cancro)
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
This lets me search for a word (via a prompt), specify how many characters before and after it to copy (via a prompt) and then pastes a highlighted version in a new document with a hyperlink to the occurrence in the original document. I wanted to maybe try and streamline this as follows if possible:
Instead of the first prompt asking which word I wanted to find; I would like it to use an excel spreadsheet (lets call it checklist) with a list of phrases on seperate lines in cloumn 'A' (example: nation wide) as a source
Instead of asking how many characters before and after: I would like it to be hard coded to be 20
Instead of asking if each occurrence is copied: I would like it to copy all occurrences
I don't know if this is possible, but was hoping that it was and would be grateful if someone could point me in the right direction, as I'm stumbling at getting the amendments to work.
Many thanks for looking at this post
Cheers
Pablo