gibbo1715
01-29-2005, 08:20 AM
Ok I have the code below to search through a number of word documents
Can anyone tell me how to add a simple progress bar when the code is running please
I ve looked at the one by DRJ at http://www.vbaexpress.com/kb/getarticle.php?kb_id=169
but cant figure out how to get it running with my code
I ve attached the worksheet for you to look at but if you open it you will need to create a sub directory called statements where the spreadsheet is saved
Many thanks for your help
Sub SearchStatements_Click()
Dim AppWrd As New Word.Application
Dim Doc As Word.Document
Dim Search As String
Dim Prompt As String
Dim Title As String
Dim PageX() As Long
Dim LineX() As Long
Dim FPath() As String
Dim FName() As String
Dim Row As Long
Dim Counter As Long
Dim Pos As Double
Dim Path As String
Dim FileName As String
Dim MyResponse As VbMsgBoxResult
Dim StartLine As Long
Dim StartPage As Long
Dim ws As Worksheet
Dim x As Long
Dim Cell As Range
Dim Rng As Range
On Error GoTo Error
Path = ThisWorkbook.Path & "\Statements"
Prompt = "What do you want to search for?"
Title = "Search Criteria"
Search = InputBox(Prompt, Title)
If Search = "" Then
GoTo Canceled
End If
'*** Confirm the procedure before continuing ***
Prompt = "Are you sure that you want to search all the files in the folder:" & _
vbCrLf & Path & " for " & """" & Search & """" & "?"
Title = "Confirm Procedure"
MyResponse = MsgBox(Prompt, vbQuestion + vbYesNo, Title)
If MyResponse = vbNo Then
GoTo Canceled
End If
Application.DisplayAlerts = False
Application.ScreenUpdating = False
'*** Loop through all Word documents and search each of them for the specified criteria***
FileName = Dir(Path & "\*.doc", vbNormal)
Do Until FileName = ""
On Error Resume Next
Set Doc = AppWrd.Documents.Open(Path & "\" & FileName, ReadOnly:=True, _
PasswordDocument:="")
If Err <> 0 Then
GoTo NextLoop:
End If
On Error GoTo 0
With Doc
AppWrd.Selection.Find.ClearFormatting
With AppWrd.Selection.Find
.Text = Search
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
On Error Resume Next
AppWrd.Selection.Find.Execute
If Err <> 0 Then
GoTo NextLoop:
End If
On Error GoTo 0
If AppWrd.Selection.Range.Text <> Search Then
GoTo NextLoop:
End If
Pos = AppWrd.Selection.Range.Information(wdHorizontalPositionRelativeToPage)
Counter = Counter + 1
ReDim Preserve LineX(1 To Counter)
ReDim Preserve PageX(1 To Counter)
ReDim Preserve FPath(1 To Counter)
ReDim Preserve FName(1 To Counter)
LineX(Counter) = AppWrd.Selection.Range.Information(wdFirstCharacterLineNumber)
PageX(Counter) = AppWrd.Selection.Range.Information(wdActiveEndPageNumber)
FPath(Counter) = Doc.Path
FName(Counter) = Doc.Name
StartLine = AppWrd.Selection.Range.Information(wdFirstCharacterLineNumber)
StartPage = AppWrd.Selection.Range.Information(wdActiveEndPageNumber)
AppWrd.Selection.Find.Execute
Do While Pos <> AppWrd.Selection.Range.Information(wdHorizontalPositionRelativeToPage) Or _
StartLine <> AppWrd.Selection.Range.Information(wdFirstCharacterLineNumber) Or _
StartPage <> AppWrd.Selection.Range.Information(wdActiveEndPageNumber)
Counter = Counter + 1
ReDim Preserve LineX(1 To Counter)
ReDim Preserve PageX(1 To Counter)
ReDim Preserve FPath(1 To Counter)
ReDim Preserve FName(1 To Counter)
If LineX(Counter - 1) = AppWrd.Selection.Range.Information(wdFirstCharacterLineNumber) And _
PageX(Counter - 1) = AppWrd.Selection.Range.Information(wdActiveEndPageNumber) And _
Pos = AppWrd.Selection.Range.Information(wdHorizontalPositionRelativeToPage) Then
Exit Do
Else
LineX(Counter) = AppWrd.Selection.Range.Information(wdFirstCharacterLineNumber)
PageX(Counter) = AppWrd.Selection.Range.Information(wdActiveEndPageNumber)
FPath(Counter) = Doc.Path
FName(Counter) = Doc.Name
Pos = AppWrd.Selection.Range.Information(wdHorizontalPositionRelativeToPage)
AppWrd.Selection.Find.Execute
End If
Loop
NextLoop:
End With
Doc.Close False
Set Doc = Nothing
On Error GoTo 0
FileName = Dir()
Loop
If Counter = 0 Then
MsgBox Search & " was not found.", vbInformation, "Zero Results For Search"
GoTo Canceled
Exit Sub
End If
Set ws = ThisWorkbook.Sheets("Sheet1")
With ws
.Range("A1").Value = "Occurrences of the word " & """" & Search & """"
.Range("A1:C1").Merge
.Range("A2").Value = "Document Path"
.Range("B2").Value = "Page Number"
.Range("C2").Value = "Line Number"
.Range("A1:C2").Font.Bold = True
.Range("A1:C2").HorizontalAlignment = xlCenter
For Row = UBound(LineX) To 1 Step -1
If PageX(Row) = 0 Or LineX(Row) = 0 Then
Else
.Range("B" & Row + 2).Value = PageX(Row)
.Range("C" & Row + 2).Value = LineX(Row)
.Hyperlinks.Add Anchor:=.Range("A" & Row + 2), _
Address:=FPath(Row) & "\" & FName(Row), TextToDisplay:=FName(Row)
End If
Next Row
.Range("A:C").EntireColumn.AutoFit
End With
Canceled:
AppWrd.Quit
Set Doc = Nothing
Set AppWrd = Nothing
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Worksheets("Sheet1").Select
Exit Sub
Error:
MsgBox "The directory Statements does not exist at this location so a search is not possible"
End Sub
Help really is appreciated
Can anyone tell me how to add a simple progress bar when the code is running please
I ve looked at the one by DRJ at http://www.vbaexpress.com/kb/getarticle.php?kb_id=169
but cant figure out how to get it running with my code
I ve attached the worksheet for you to look at but if you open it you will need to create a sub directory called statements where the spreadsheet is saved
Many thanks for your help
Sub SearchStatements_Click()
Dim AppWrd As New Word.Application
Dim Doc As Word.Document
Dim Search As String
Dim Prompt As String
Dim Title As String
Dim PageX() As Long
Dim LineX() As Long
Dim FPath() As String
Dim FName() As String
Dim Row As Long
Dim Counter As Long
Dim Pos As Double
Dim Path As String
Dim FileName As String
Dim MyResponse As VbMsgBoxResult
Dim StartLine As Long
Dim StartPage As Long
Dim ws As Worksheet
Dim x As Long
Dim Cell As Range
Dim Rng As Range
On Error GoTo Error
Path = ThisWorkbook.Path & "\Statements"
Prompt = "What do you want to search for?"
Title = "Search Criteria"
Search = InputBox(Prompt, Title)
If Search = "" Then
GoTo Canceled
End If
'*** Confirm the procedure before continuing ***
Prompt = "Are you sure that you want to search all the files in the folder:" & _
vbCrLf & Path & " for " & """" & Search & """" & "?"
Title = "Confirm Procedure"
MyResponse = MsgBox(Prompt, vbQuestion + vbYesNo, Title)
If MyResponse = vbNo Then
GoTo Canceled
End If
Application.DisplayAlerts = False
Application.ScreenUpdating = False
'*** Loop through all Word documents and search each of them for the specified criteria***
FileName = Dir(Path & "\*.doc", vbNormal)
Do Until FileName = ""
On Error Resume Next
Set Doc = AppWrd.Documents.Open(Path & "\" & FileName, ReadOnly:=True, _
PasswordDocument:="")
If Err <> 0 Then
GoTo NextLoop:
End If
On Error GoTo 0
With Doc
AppWrd.Selection.Find.ClearFormatting
With AppWrd.Selection.Find
.Text = Search
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
On Error Resume Next
AppWrd.Selection.Find.Execute
If Err <> 0 Then
GoTo NextLoop:
End If
On Error GoTo 0
If AppWrd.Selection.Range.Text <> Search Then
GoTo NextLoop:
End If
Pos = AppWrd.Selection.Range.Information(wdHorizontalPositionRelativeToPage)
Counter = Counter + 1
ReDim Preserve LineX(1 To Counter)
ReDim Preserve PageX(1 To Counter)
ReDim Preserve FPath(1 To Counter)
ReDim Preserve FName(1 To Counter)
LineX(Counter) = AppWrd.Selection.Range.Information(wdFirstCharacterLineNumber)
PageX(Counter) = AppWrd.Selection.Range.Information(wdActiveEndPageNumber)
FPath(Counter) = Doc.Path
FName(Counter) = Doc.Name
StartLine = AppWrd.Selection.Range.Information(wdFirstCharacterLineNumber)
StartPage = AppWrd.Selection.Range.Information(wdActiveEndPageNumber)
AppWrd.Selection.Find.Execute
Do While Pos <> AppWrd.Selection.Range.Information(wdHorizontalPositionRelativeToPage) Or _
StartLine <> AppWrd.Selection.Range.Information(wdFirstCharacterLineNumber) Or _
StartPage <> AppWrd.Selection.Range.Information(wdActiveEndPageNumber)
Counter = Counter + 1
ReDim Preserve LineX(1 To Counter)
ReDim Preserve PageX(1 To Counter)
ReDim Preserve FPath(1 To Counter)
ReDim Preserve FName(1 To Counter)
If LineX(Counter - 1) = AppWrd.Selection.Range.Information(wdFirstCharacterLineNumber) And _
PageX(Counter - 1) = AppWrd.Selection.Range.Information(wdActiveEndPageNumber) And _
Pos = AppWrd.Selection.Range.Information(wdHorizontalPositionRelativeToPage) Then
Exit Do
Else
LineX(Counter) = AppWrd.Selection.Range.Information(wdFirstCharacterLineNumber)
PageX(Counter) = AppWrd.Selection.Range.Information(wdActiveEndPageNumber)
FPath(Counter) = Doc.Path
FName(Counter) = Doc.Name
Pos = AppWrd.Selection.Range.Information(wdHorizontalPositionRelativeToPage)
AppWrd.Selection.Find.Execute
End If
Loop
NextLoop:
End With
Doc.Close False
Set Doc = Nothing
On Error GoTo 0
FileName = Dir()
Loop
If Counter = 0 Then
MsgBox Search & " was not found.", vbInformation, "Zero Results For Search"
GoTo Canceled
Exit Sub
End If
Set ws = ThisWorkbook.Sheets("Sheet1")
With ws
.Range("A1").Value = "Occurrences of the word " & """" & Search & """"
.Range("A1:C1").Merge
.Range("A2").Value = "Document Path"
.Range("B2").Value = "Page Number"
.Range("C2").Value = "Line Number"
.Range("A1:C2").Font.Bold = True
.Range("A1:C2").HorizontalAlignment = xlCenter
For Row = UBound(LineX) To 1 Step -1
If PageX(Row) = 0 Or LineX(Row) = 0 Then
Else
.Range("B" & Row + 2).Value = PageX(Row)
.Range("C" & Row + 2).Value = LineX(Row)
.Hyperlinks.Add Anchor:=.Range("A" & Row + 2), _
Address:=FPath(Row) & "\" & FName(Row), TextToDisplay:=FName(Row)
End If
Next Row
.Range("A:C").EntireColumn.AutoFit
End With
Canceled:
AppWrd.Quit
Set Doc = Nothing
Set AppWrd = Nothing
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Worksheets("Sheet1").Select
Exit Sub
Error:
MsgBox "The directory Statements does not exist at this location so a search is not possible"
End Sub
Help really is appreciated