How to get page number count from oDoc Excel VBA? - excel

I am trying to extract the page number from where a word is find. This is my current code:
Sub LocateSearchItem()
Dim shtSearchItem As Worksheet
Dim shtExtract As Worksheet
Dim oWord As Word.Application
Dim WordNotOpen As Boolean
Dim oDoc As Word.Document
Dim oRange As Word.Range
Dim LastRow As Long
Dim CurrentRowShtSearchItem As Long
Dim CurrentRowShtExtract As Long
Dim myPara As Long
On Error Resume Next
Set oWord = GetObject(, "Word.Application")
If Err Then
Set oWord = New Word.Application
WordNotOpen = True
End If
On Error GoTo Err_Handler
oWord.Visible = True
oWord.Activate
Set oDoc = oWord.Documents.Open("C:\Users\Moham\Desktop\mydocx.docx")
Set shtSearchItem = ThisWorkbook.Worksheets(1)
If ThisWorkbook.Worksheets.Count < 2 Then
ThisWorkbook.Worksheets.Add After:=shtSearchItem
End If
Set shtExtract = ThisWorkbook.Worksheets(2)
LastRow = shtSearchItem.UsedRange.Rows(shtSearchItem.UsedRange.Rows.Count).Row
For CurrRowShtSearchItem = 2 To LastRow
Set oRange = oDoc.Range
With oRange.Find
.Text = shtSearchItem.Cells(CurrRowShtSearchItem, 1).Text
.MatchCase = False
.MatchWholeWord = True
While oRange.Find.Execute = True
oRange.Select
'This is the important part
myPara = oDoc.Range(0, oWord.Selection.Paragraphs(1).Range.End).Paragraphs.Count
CurrRowShtExtract = CurrRowShtExtract + 1
shtExtract.Cells(CurrRowShtExtract, 1).Value = .Text
shtExtract.Cells(CurrRowShtExtract, 2).Value = myPara
shtExtract.Cells(CurrRowShtExtract, 3) = oDoc.Paragraphs(myPara).Range
oRange.Collapse wdCollapseEnd
Wend
End With
Next CurrRowShtSearchItem
If WordNotOpen Then
oWord.Quit
End If
Set oWord = Nothing
Set oDoc = Nothing
Exit Sub
Err_Handler:
MsgBox "Word caused a problem. " & Err.Description, vbCritical, "Error: " & Err.Number
If WordNotOpen Then
oWord.Quit
End If
End Sub
I am not able to find the page number element in oDoc.
How to get the page number of that paragraph? Also currently the paragraph counts even the titles. Is there a way to avoid counting titles as well as counting blank paragraphs?
For example, currently it says the "Hello daniel" to be in para 5.
HELLO ---> Format Title
hi there all ----> para 2
this is your professor ----->para 3
-------> para 4
say hello to him ------------->para 5
Hello Daniel --------------> para 6
It should actually say para 4 because the first line is title and there is one empty para above "say hello to him" para.

Related

Extract specific data from Word to Excel

I have a Word file that has table with 5 columns: Step, Document, Doc #, Compo and Lot #, Sign, Date. I need to search for "Lot #" and "E#" in the word file then get the Step number, the text of row contains the string into an Excel file. I found a code that need to have the keywords in Sheet 1 of Excel then extract the data from Word into Sheet 2 with 1st column as keyword, 2nd column as row number in Word and 3rd column is the text of that row.
Is there any way I can hard code the keywords with options/message box to choose the keyword into VBA module instead of Sheet 1 and get the data in Sheet 1 with 1st column as keyword, 2nd column as the value in Step column in Word and 3rd column is the text of that row?
I'm pretty new to VBA so I don't know how to implement those.
Sub LocateSearchItem()
Dim shtSearchItem As Worksheet
Dim shtExtract As Worksheet
Dim oWord As Word.Application
Dim WordNotOpen As Boolean
Dim oDoc As Word.Document
Dim oRange As Word.Range
Dim LastRow As Long ' last row with data in shtSearchItem
Dim CurrRowShtSearchItem As Long ' current row in shtSearchItem
Dim CurrRowShtExtract As Long ' current row in shtExtract
Dim myPara As Long
On Error Resume Next
Set oWord = GetObject(, "Word.Application")
wdFileName = Application.GetOpenFilename("Word files (*.docx),*.docx", , _
"Browse for file containing table to be imported")
If wdFileName = False Then Exit Sub '(user cancelled import file browser)
Set oDoc = GetObject(wdFileName) 'open Word file
If Err Then
Set oWord = New Word.Application
WordNotOpen = True
End If
On Error GoTo Err_Handler
oWord.Visible = True
oWord.Activate
Set shtSearchItem = ThisWorkbook.Worksheets(1)
If ThisWorkbook.Worksheets.Count < 2 Then
ThisWorkbook.Worksheets.Add After:=shtSearchItem
End If
Set shtExtract = ThisWorkbook.Worksheets(2)
LastRow = shtSearchItem.UsedRange.Rows(shtSearchItem.UsedRange.Rows.Count).Row
For CurrRowShtSearchItem = 2 To LastRow
Set oRange = oDoc.Range
With oRange.Find
.Text = shtSearchItem.Cells(CurrRowShtSearchItem, 1).Text
.MatchCase = False
.MatchWholeWord = True
While oRange.Find.Execute = True
oRange.Select
myPara = oDoc.Range(0, oWord.Selection.Paragraphs(1).Range.End).Paragraphs.Count
CurrRowShtExtract = CurrRowShtExtract + 1
shtExtract.Cells(CurrRowShtExtract, 1).Value = .Text
shtExtract.Cells(CurrRowShtExtract, 2).Value = myPara
shtExtract.Cells(CurrRowShtExtract, 3) = oDoc.Paragraphs(myPara).Range
oRange.Collapse wdCollapseEnd
Wend
End With
Next CurrRowShtSearchItem
If WordNotOpen Then
oWord.Quit
End If
'Release object references
Set oWord = Nothing
Set oDoc = Nothing
Exit Sub
Err_Handler:
MsgBox "Word caused a problem. " & Err.Description, vbCritical, "Error: " & Err.Number
If WordNotOpen Then
oWord.Quit
End If
End Sub
What I got from the current code

wend without while

Getting wend without while error: I am trying to extract paragraph with particular keyword and Color from Doc to Excel.
Keywords for a paragraph is written in Sheet 1 row 2 to last row.
Next Paragraph with a keyword is extracted in Sheet2.
I will get a wend without while error when I try to get a paragraph with particular color after the keyword.
Code:
Sub LocateSearchItem()
Dim shtSearchItem As Worksheet
Dim shtExtract As Worksheet
Dim oWord As Word.Application
Dim WordNotOpen As Boolean
Dim oDoc As Word.Document
Dim oRange As Word.Range
Dim LastRow As Long
Dim CurrRowShtSearchItem As Long
Dim CurrRowShtExtract As Long
Dim myPara As Long
Dim myPara1 As Long
Dim I As Long
On Error Resume Next
Set oWord = GetObject(, "Word.Application")
Set oWord = New Word.Application
If Err Then
Set oWord = New Word.Application
WordNotOpen = True
End If
On Error GoTo Err_Handler
oWord.Visible = True
oWord.Activate
Set oDoc = oWord.Documents.Open("C:\CC-SyPRS\Automating Verification activity\Work in Progress\Test.docx")
Set shtSearchItem = ThisWorkbook.Worksheets(1)
If ThisWorkbook.Worksheets.Count < 2 Then
ThisWorkbook.Worksheets.Add After:=shtSearchItem
End If
Set shtExtract = ThisWorkbook.Worksheets(2)
LastRow = shtSearchItem.UsedRange.Rows(shtSearchItem.UsedRange.Rows.Count).Row
For CurrRowShtSearchItem = 2 To LastRow
Set oRange = oDoc.Range
With oRange.Find
.Text = shtSearchItem.Cells(CurrRowShtSearchItem, 1).Text
.MatchCase = False
.MatchWholeWord = True
While oRange.Find.Execute = True
oRange.Select
myPara = oDoc.Range(0, oWord.Selection.Paragraphs(1).Range.End).Paragraphs.Count
myPara1 = myPara + 1
Set objParagraph = oDoc.Paragraphs(myPara1).Range
For I = 1 To 5
If objParagraph.Font.ColorIndex = wdGreen Then
shtExtract.Cells(CurrRowShtExtract, 2) = oDoc.Paragraphs(myPara1).Range
Else
I = I + 1
myPara1 = myPara + I
End If
CurrRowShtExtract = CurrRowShtExtract + 1
oRange.Collapse wdCollapseEnd
Wend
End With
Next CurrRowShtSearchItem
If WordNotOpen Then
oWord.Quit
End If
'Release object references
Set oWord = Nothing
Set oDoc = Nothing
Exit Sub
Err_Handler:
MsgBox "Word caused a problem. " & Err.Description, vbCritical, "Error: " & Err.Number
If WordNotOpen Then
oWord.Quit
End If
End Sub
This is why proper indentation is really useful.
Sub LocateSearchItem()
Dim shtSearchItem As Worksheet
Dim shtExtract As Worksheet
Dim oWord As Word.Application
Dim WordNotOpen As Boolean
Dim oDoc As Word.Document
Dim oRange As Word.Range
Dim LastRow As Long
Dim CurrRowShtSearchItem As Long
Dim CurrRowShtExtract As Long
Dim myPara As Long
Dim myPara1 As Long
Dim I As Long
On Error Resume Next
Set oWord = GetObject(, "Word.Application")
Set oWord = New Word.Application
If Err Then
Set oWord = New Word.Application
WordNotOpen = True
End If
On Error GoTo Err_Handler
oWord.Visible = True
oWord.Activate
Set oDoc = oWord.Documents.Open("C:\CC-SyPRS\Automating Verification activity\Work in Progress\Test.docx")
Set shtSearchItem = ThisWorkbook.Worksheets(1)
If ThisWorkbook.Worksheets.Count < 2 Then
ThisWorkbook.Worksheets.Add After:=shtSearchItem
End If
Set shtExtract = ThisWorkbook.Worksheets(2)
LastRow = shtSearchItem.UsedRange.Rows(shtSearchItem.UsedRange.Rows.Count).Row
For CurrRowShtSearchItem = 2 To LastRow
Set oRange = oDoc.Range
With oRange.Find
.Text = shtSearchItem.Cells(CurrRowShtSearchItem, 1).Text
.MatchCase = False
.MatchWholeWord = True
While oRange.Find.Execute = True
oRange.Select
myPara = oDoc.Range(0, oWord.Selection.Paragraphs(1).Range.End).Paragraphs.Count
myPara1 = myPara + 1
Set objParagraph = oDoc.Paragraphs(myPara1).Range
For I = 1 To 5
If objParagraph.Font.ColorIndex = wdGreen Then
shtExtract.Cells(CurrRowShtExtract, 2) = oDoc.Paragraphs(myPara1).Range
Else
I = I + 1
myPara1 = myPara + I
End If
CurrRowShtExtract = CurrRowShtExtract + 1
oRange.Collapse wdCollapseEnd
' Oops! No closing tag for the 'For' statement. Add 'Next I' here
Wend
End With
Next CurrRowShtSearchItem
If WordNotOpen Then
oWord.Quit
End If
'Release object references
Set oWord = Nothing
Set oDoc = Nothing
Exit Sub
Err_Handler:
MsgBox "Word caused a problem. " & Err.Description, vbCritical, "Error: " & Err.Number
If WordNotOpen Then
oWord.Quit
End If
End Sub
The error message is quite misleading anyway, as #freeflow mentioned
By the way, you have a With on line 41, which is not closed on line 45. As you do not use the Find object anymore, you can close it and start the while loop separately.

Finding rest of sentence after finding an specific word

I have created a code that searches different words in a column in a word document.
After finding the word, the code returns the value "yes" to the excel.
I want the code to extract the rest of the sentence after finding the word that I´m looking for.
The rest of the sentences are always something like:
Update system format.
Search for other inputs.
Havent found the sentence that it needs to do.
In conclusion, they are always a small sentence and a new paragraph after.
The code that I have developed is the following:
Sub findSubprocesos()
Dim wrdApp As New Word.Application
Dim wrdDoc As Word.Document
Set wrdApp = CreateObject("Word.Application")
Dim FindWord As String
Dim List As String
Dim Dict As Object
Dim NextFormula As Range
Dim RefElem As Range
Dim Key
Dim Wbk As Workbook: Set Wbk = ThisWorkbook
Set Dict = CreateObject("Scripting.Dictionary")
Set NextFormula = Worksheets("Datos2").Range("V2:V5")
With Dict
For Each RefElem In NextFormula
If Not .Exists(RefElem) And Not IsEmpty(RefElem) Then
Sheets("Datos2").Range("R3").Value = RefElem.Value
Debug.Print RefElem
FindSubs
On Error GoTo Skip
End If
Next RefElem
Skip:
End With
End Sub
Private Sub FindSubs()
Dim wrdApp As New Word.Application
Dim wrdDoc As Word.Document
Set wrdApp = CreateObject("Word.Application")
Dim FindWord As String
Dim List As String
Dim Dict As Object
Dim NextFormula As Range
Dim RefElem As Range
Dim Key
Dim Wbk As Workbook: Set Wbk = ThisWorkbook
Range("U3:U50").ClearContents
wrdApp.Visible = True
Set wrdDoc = wrdApp.Documents.Open("C:\Users\rriveragarrido\Desktop\Proyectos\Proyecto solaris (endesa) (PROPIO)\prueba macros\ZZZ\Narrativas antiguas\1059\1059_NAR_OTC.RC.03.01_CC.END.GEN_ENG_31.12.20.docx", OpenAndRepair:=True)
Dim cell As Range
Dim bIsEmpty As Boolean
bIsEmpty = False
For n = 3 To 20
For Each cell In Worksheets("Datos").Range("S" & n)
If IsEmpty(cell) = False Then
FindWord = Wbk.Sheets("Datos2").Range("S" & n).Value 'Modify as necessary.
wrdApp.Selection.WholeStory
wrdApp.Selection.FIND.ClearFormatting
With wrdApp.Selection.FIND
.ClearFormatting
.Text = FindWord
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = True
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
If .Execute Then
Sheets("Datos2").Range("U" & n).Value = "Yes"
Else
'Sheets("Datos2").Range("T" & n).Value = "No"
wrdApp.Quit SaveChanges:=0
Sheets("Datos2").Range("U3:U50").Copy Sheets("Subprocesos").Range("A3:A50").End(xlToRight).Offset(0, 1)
GoTo Skip2
End If
End With
End If
Next cell
Next
Skip2:
End Sub
This is the part were I need to extract the rest of the sentence:
If .Execute Then
Sheets("Datos2").Range("U" & n).Value = "Yes"
Else
'Sheets("Datos2").Range("T" & n).Value = "No"
wrdApp.Quit SaveChanges:=0
Sheets("Datos2").Range("U3:U50").Copy Sheets("Subprocesos").Range("A3:A50").End(xlToRight).Offset(0, 1)
Currently is only writing "yes" when the sentence is found and pasting the information in a column and going to the next word if it is not found.
What you want to do is possible by using the Sentences collection of the document. Hopefully you can adapt the sample code below to your needs:
Option Explicit
Sub test()
Dim foundSentences As Collection
Set foundSentences = FindTheSentencesContaining(ThisWord:="access", _
FromThisDoc:="C:\Temp\test.docx")
If foundSentences Is Nothing Then
Debug.Print "The word doc was not found!"
Else
Debug.Print "found " & foundSentences.Count & " sentences"
Dim sentence As Variant
For Each sentence In foundSentences
Debug.Print sentence
Next sentence
End If
End Sub
Function FindTheSentencesContaining(ByVal ThisWord As String, _
ByVal FromThisDoc As String) As Collection
Dim wordWasRunning As Boolean
wordWasRunning = IsMSWordRunning
Dim wordApp As Word.Application
Set wordApp = AttachToMSWordApplication
On Error Resume Next
Dim wordDoc As Word.Document
Set wordDoc = wordApp.Documents.Open(Filename:=FromThisDoc, ReadOnly:=True)
On Error GoTo 0
If wordDoc Is Nothing Then Exit Function
Dim allSentences As Collection
Set allSentences = New Collection
Dim sentence As Variant
For Each sentence In wordDoc.Sentences
sentence.Select
With wordApp.Selection
.Find.Text = ThisWord
.Find.Forward = True
.Find.Wrap = wdFindStop
.Find.MatchCase = False
If .Find.Execute Then
'--- extend the selection to include the whole sentence
.Expand Unit:=wdSentence
allSentences.Add wordApp.Selection.Text
'--- move the cursor to the end of the sentence to continue looking
.Collapse Direction:=wdCollapseEnd
.MoveEnd Unit:=wdSentence
Else
'--- didn't find it, move to the next sentence
End If
End With
Next sentence
wordDoc.Close SaveChanges:=False
If Not wordWasRunning Then
wordApp.Quit
End If
Set FindTheSentencesContaining = allSentences
End Function
In a separate module, I have the following code (pulled from my library of code to reuse):
Option Explicit
Public Function IsMSWordRunning() As Boolean
'--- quick check to see if an instance of MS Word is running
Dim msApp As Object
On Error Resume Next
Set msApp = GetObject(, "Word.Application")
If Err > 0 Then
'--- not running
IsMSWordRunning = False
Else
'--- running
IsMSWordRunning = True
End If
End Function
Public Function AttachToMSWordApplication() As Word.Application
'--- finds an existing and running instance of MS Word, or starts
' the application if one is not already running
Dim msApp As Word.Application
On Error Resume Next
Set msApp = GetObject(, "Word.Application")
If Err > 0 Then
'--- we have to start one
' an exception will be raised if the application is not installed
Set msApp = CreateObject("Word.Application")
End If
Set AttachToMSWordApplication = msApp
End Function
A simple demo outputting the content to a message box, for all found instances:
Sub Demo()
With ActiveDocument.Range
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = InputBox("What is the Text to Find")
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Do While .Find.Execute
With .Duplicate
.End = .Sentences.First.End
MsgBox .Text
End With
.Collapse wdCollapseEnd
Loop
End With
End Sub
Do be aware, though, that VBA has no idea what a grammatical sentence is. For example, consider the following:
Mr. Smith spent $1,234.56 at Dr. John's Grocery Store, to buy:
10.25kg of potatoes; 10kg of avocados; and 15.1kg of Mrs. Green's Mt. Pleasant macadamia nuts.
For you and me, that would count as one sentence; for VBA it counts as 5 sentences.

Match first row of first column if matched then send its corresponding row of second column into Word document

I am having an excel with two columns Requirement and Source. I have another Word document with Requirement which are there in excel. I want it to be matched. If it is matched then its corresponding source need to be sent to Requirement in word document.
The excel file data:
In the word document the data should be displayed like this:
enter image description here
I tried in this way:
Sub SearchItem()
Dim shtSearchItem As Worksheet
Dim shtExtract As Worksheet
Dim oWord As Word.Application
Dim WordNotOpen As Boolean
Dim oDoc As Word.Document
Dim oRange As Word.Range
Dim LastRow As Long
Dim CurrRowShtSearchItem As Long
Dim CurrRowShtExtract As Long
Dim myPara As Long
On Error Resume Next
Set oWord = GetObject(, "Word.Application")
If Err Then
Set oWord = New Word.Application
WordNotOpen = True
End If
On Error GoTo Err_Handler
oWord.Visible = True
oWord.Activate
Set oDoc = oWord.Documents.Open("File Location")
Set shtSearchItem = ThisWorkbook.Worksheets(1)
If ThisWorkbook.Worksheets.Count < 2 Then
ThisWorkbook.Worksheets.Add After:=shtSearchItem
End If
Set shtExtract = ThisWorkbook.Worksheets(2)
LastRow = shtSearchItem.UsedRange.Rows(shtSearchItem.UsedRange.Rows.Count).Row
For CurrRowShtSearchItem = 2 To LastRow
Set oRange = oDoc.Range
With oRange.Find
.Text = shtSearchItem.Cells(CurrRowShtSearchItem, 1).Text
.MatchCase = False
.MatchWholeWord = True
While oRange.Find.Execute = True
oRange.Select
If .Found Then
oRange.InsertAfter ("Reference" & ":") ' <= what need to be done?
End If
oRange.Start = oRange.End
oRange.End = ActiveDocument.Range.End
oRange.Collapse wdCollapseEnd
Wend
End With
Next CurrRowShtSearchItem
If WordNotOpen Then
oWord.Quit
End If
'Release object references
Set oWord = Nothing
Set oDoc = Nothing
Exit Sub
Err_Handler:
MsgBox "Word caused a problem. " & Err.Description, vbCritical, "Error: " & Err.Number
If WordNotOpen Then
oWord.Quit
End If
End Sub
Please Help. Thank You
Try something based on:
Sub SendRefsToDoc()
'Note: A reference to the Word library must be set, via Tools|References
Dim wdApp As New Word.Application, wdDoc As Word.Document, StrNm As String
Dim r As Long, xlFList As String, xlRList As String
StrNm = "C:\Users\" & Environ("UserName") & "\Documents\MyDocument.docx"
If Dir(StrNm) <> "" Then
With Worksheets("Sheet1")
For r = 2 To .Cells(.Rows.Count, 1).End(xlUp).Row
If .Range("A" & r).Text = "" Then
xlRList = xlRList & ", " & Trim(.Range("B" & r))
Else
xlFList = xlFList & "|" & Trim(.Range("A" & r))
xlRList = xlRList & "|" & Trim(.Range("B" & r))
End If
Next
End With
With wdApp
.Visible = False
Set wdDoc = Documents.Open(Filename:=StrNm, AddToRecentFiles:=False, Visible:=False)
With wdDoc
For r = 1 To UBound(Split(xlFList, "|"))
With .Range
With .Find
.Replacement.ClearFormatting
.Text = Split(xlFList, "|")(r)
.Replacement.Text = ""
.Forward = True
.Format = False
.Wrap = wdFindStop
End With
Do While .Find.Execute
.Paragraphs.First.Range.Characters.Last.InsertBefore vbCr _
& "Reference: " & Split(xlRList, "|")(r)
With .Paragraphs.First.Range.Font
.Bold = True
.Italic = True
End With
With .Paragraphs.Last.Range.Font
.Bold = False
.Italic = False
End With
.Collapse wdCollapseEnd
Loop
End With
Next
.Close True
End With
.Quit
End With
Else
MsgBox "File not found: " & vbCr & StrNm, vbExclamation
End If
Set wdDoc = Nothing: Set wdApp = Nothing
End Sub

Copy text from Word to Excel based on a list of search words

Hello dear forum members,
in the context of a research work at my university I have to transfer text passages from Word documents into an Excel file based on keywords.
This is a list of keywords (all listed below each other in an Excel column) and several Word documents (about 80-100 with 400 pages each).
The program should search the Word document for the keywords and if a word is found, the corresponding word + 350 characters before and after the word should be copied to an Excel line. Additionally, the name of the document and the number of pages should be copied. Each found word should be copied into a new line.
Based on first researches at Google I have received the following code. Most of it already works with this code.
I need your help with the following two points:
1.) How can I extend the text to be copied? If a search word is found in the word document, the word + 350 characters before and after the word should be copied.
2.) How should a loop look like, so that all Word documents in a folder are processed one after the other?
Since I did not find a solution after trying for a long time, I am happy about every tip or solution.
Sub LocateSearchItem_Test22()
Dim shtSearchItem As Worksheet
Dim shtExtract As Worksheet
Dim oWord As Word.Application
Dim WordNotOpen As Boolean
Dim oDoc As Word.Document
Dim oRange As Word.Range
Dim LastRow As Long
Dim CurrRowShtSearchItem As Long
Dim CurrRowShtExtract As Long
Dim myPara As Long
Dim myLine As Long
Dim myPage As Long
Dim oDocName As Variant
On Error Resume Next
Application.ScreenUpdating = False
Set oWord = GetObject(, "Word.Application")
If Err Then
Set oWord = New Word.Application
WordNotOpen = True
End If
On Error GoTo Err_Handler
oWord.Visible = True
oWord.Activate
Set oDoc = oWord.Documents.Open("C:\Users\Lenovo\Downloads\Data fronm Word to Excel\Testdatei.docx")
oDocName = ActiveDocument.Name
Set shtSearchItem = ThisWorkbook.Worksheets(1)
If ThisWorkbook.Worksheets.Count < 2 Then
ThisWorkbook.Worksheets.Add After:=shtSearchItem
End If
Set shtExtract = ThisWorkbook.Worksheets(2)
LastRow = shtSearchItem.UsedRange.Rows(shtSearchItem.UsedRange.Rows.Count).Row
For CurrRowShtSearchItem = 2 To LastRow
Set oRange = oDoc.Range
With oRange.Find
.Text = shtSearchItem.Cells(CurrRowShtSearchItem, 1).Text
.MatchCase = False
'.MatchWholeWord = False
.MatchWildcards = True
While oRange.Find.Execute = True
oRange.Select
myPara = oDoc.Range(0, oWord.Selection.Paragraphs(1).Range.End).Paragraphs.Count
myPage = oWord.Selection.Information(wdActiveEndAdjustedPageNumber)
myLine = oWord.Selection.Information(wdFirstCharacterLineNumber)
CurrRowShtExtract = CurrRowShtExtract + 1
shtExtract.Cells(CurrRowShtExtract, 1).Value = .Text
shtExtract.Cells(CurrRowShtExtract, 2).Value = myPara
shtExtract.Cells(CurrRowShtExtract, 3).Value = myPage
shtExtract.Cells(CurrRowShtExtract, 4).Value = myLine
shtExtract.Cells(CurrRowShtExtract, 5).Value = oDocName
shtExtract.Cells(CurrRowShtExtract, 6) = oDoc.Paragraphs(myPara).Range
oRange.Collapse wdCollapseEnd
Wend
End With
Next CurrRowShtSearchItem
If WordNotOpen Then
oWord.Quit
End If
'Release object references
Set oWord = Nothing
Set oDoc = Nothing
Exit Sub
Err_Handler:
MsgBox "Word caused a problem. " & Err.Description, vbCritical, "Error: " & Err.Number
If WordNotOpen Then
oWord.Quit
End If
End Sub
I'm going to specifically focus on the Word part, because that is my expertise. It looks like you know a fair bit about VBA, so I'm just going to answer with snippets.
Here's your find:
With oRange.Find
.Text = shtSearchItem.Cells(CurrRowShtSearchItem, 1).Text
.MatchCase = False
'.MatchWholeWord = False
.MatchWildcards = True 'do you really want wildcards?
.Wrap = wdFindStop
While .Execute = True
myPara = oDoc.Range(0, oRange.End).Paragraphs.Count
myPage = oRange.Information(wdActiveEndAdjustedPageNumber)
myLine = oRange.Information(wdFirstCharacterLineNumber)
'Expand range size begins here
oRange.MoveStart wdCharacter, -350 'not sure if you want the info of just the word or the word +/- 350 characters
oRange.MoveEnd wdCharacter, 350
CurrRowShtExtract = CurrRowShtExtract + 1
shtExtract.Cells(CurrRowShtExtract, 1).Value = .Text
shtExtract.Cells(CurrRowShtExtract, 2).Value = myPara
shtExtract.Cells(CurrRowShtExtract, 3).Value = myPage
shtExtract.Cells(CurrRowShtExtract, 4).Value = myLine
shtExtract.Cells(CurrRowShtExtract, 5).Value = oDocName
shtExtract.Cells(CurrRowShtExtract, 6) = oRange.Text
oRange.Collapse wdCollapseEnd
Wend
End With
Don't select anything, ever, if you can help it. Almost everything in Word can be done without ever ever ever using selection. Declare the range and manipulate the range. There's no need to select it.
As far as looping through each document in the folder, take a look at FileSystemObject. The documentation is horrendous but Google results are generally pretty good.

Resources