Read multiple word document in a folder and count number of occurance of a string

[thedark123]

I am doing a coding for my company, so i got a few word documents which resides in a folder, what i need to do is to use the script or marco to count the number of selected string in every document that contains inside the folder, and in return a new word document which be generated and show the results..

There is some problem with it, how do i use ActiveDocument to process multiple documents?

and can i use ActiveDocument.Word or something to read a string such as "Test Case ID" and the results will show its occurance from all documents in the folder.

Here is my coding:


Sub CommandButton1_Click()


Dim x As String, MyName As String
Dim i As Integer
Dim Response As Integer, TotalFiles As Integer
Dim counter As Integer
Dim test As String

On Error Resume Next

Folder:

' Prompt the user for the folder to list.
x = InputBox(Prompt:="What folder do you want to list?" & vbCr & vbCr _
& "For example: C:\My Documents", _
Default:=Options.DefaultFilePath(wdDocumentsPath))

If x = "" Or x = " " Then
If MsgBox("Either you did not type a folder name correctly" _
& vbCr & "or you clicked Cancel. Do you want to quit?" _
& vbCr & vbCr & _
"If you want to type a folder name, click No." & vbCr & _
"If you want to quit, click Yes.", vbYesNo) = vbYes Then
Exit Sub
Else
GoTo Folder
End If
End If

' Test if folder exists.
If Dir(x, vbDirectory) = "" Then
MsgBox "The folder does not exist. Please try again."
GoTo Folder
End If

' Search the specified folder for files
' and type the listing in the document.
With Application.FileSearch
.NewSearch
.FileType = msoFileTypeOfficeFiles
' Change the .FileType to the type of files you are looking for;
' for example, the following line finds all files:
' .FileType = msoFileTypeAllFiles
.LookIn = x
.Execute
TotalFiles = .FoundFiles.Count
If TotalFiles = 0 Then
MsgBox ("There are no files in the folder!" & _
"Please type another folder to list.")
GoTo Folder
End If

' Create a new document for the file listing.
Application.Documents.Add
ActiveDocument.ActiveWindow.View = wdPrintView

' Set tabs.
With Selection.ParagraphFormat.TabStops
.Add _
Position:=InchesToPoints(3), _
Alignment:=wdAlignTabLeft, _
Leader:=wdTabLeaderSpaces
.Add _
Position:=InchesToPoints(4), _
Alignment:=wdAlignTabLeft, _
Leader:=wdTabLeaderSpaces
End With


' Type the file list headings.
Selection.TypeText "File Listing of the "

With Selection.Font
.AllCaps = True
.Bold = True
End With
Selection.TypeText x
With Selection.Font
.AllCaps = False
.Bold = False
End With
Selection.TypeText " folder!" & vbLf
Selection.Font.Underline = wdUnderlineSingle
Selection.TypeText vbLf & "File Name" & vbTab & "File Size" _
& vbTab & "File Date/Time" & vbTab & "Total Flow" & vbLf & vbLf
Selection.Font.Underline = wdUnderlineNone

' Type results into table

For i = 1 To TotalFiles
MyName = .FoundFiles(i)
Documents.Open FileName:=.FoundFiles(i)

counter = -5
For j = 1 To ActiveDocument.Sentences.Count
If ActiveDocument.Sentences(j).Style = "Heading 2" Then
counter = counter + 1
End If
Next j
ActiveDocument.Close

Selection.TypeText MyName & vbTab & FileLen(MyName) _
& vbTab & FileDateTime(MyName) & vbTab & counter & vbLf
Next i

' Type the total number of files found.
Selection.TypeText vbLf & "Total files in folder = " & TotalFiles & _
" files."
End With

'If MsgBox("Do you want to print this folder list?", vbYesNo) = vbYes Then
'Application.ActiveDocument.PrintOut
'End If

If MsgBox("Do you want to list another folder?", vbYesNo) = vbYes Then
GoTo Folder
End If
End Sub

[mdmackillop]

Hi,
Welcome to VBAX
There are a couple of KB items here for processing all files in a folder/sub-folder. If you need further assistance, let us know
Regards
MD

http://vbaexpress.com/kb/getarticle.php?kb_id=13
http://vbaexpress.com/kb/getarticle.php?kb_id=76

[thedark123]

i got 1 more question how do I integrate this piece of coding

(this coding will scan through the lines to find all the headings in a document and then count it and will display out.)

Dim Count123 As Integer
Count123 = 0



With ActiveDocument.Content.Find
.ClearFormatting
.Style = "Heading 2"

Do While .Execute(Forward:=True, Format:=True) = True
With .Parent

Count123 = Count123 + 1

If .End = ActiveDocument.Content.End Then
.StartOf Unit:=wdParagraph, Extend:=wdMove
.InsertAfter ":"

Exit Do

Else

.StartOf Unit:=wdParagraph, Extend:=wdMove
.InsertAfter ":"
.Move Unit:=wdParagraph, Count:=1

End If
End With


Loop
End With





into this



Sub ProcessAll(sPath As String)
Dim WdDoc As Document, sFile As String

sFile = Dir(sPath & "*.doc")
'Loop through all .doc files in that path
Do While sFile <> ""
Set WdDoc = Application.Documents.Open(sPath & sFile)

'Do something with that Document, insert whatever you want to do here
Debug.Print WdDoc.Name
'You can save it, if you like, here it's not saved
WdDoc.Close wdDoNotSaveChanges
sFile = Dir
Loop
End Sub






At the btm of this code i can state wad folder directory to open.

and also can i integrate this into the exisiting code u show me?

it will be better if i can state wad folder to open and the macro will look throught that folder



Folder:
' Prompt the user for the folder to list.
x = InputBox(Prompt:="What folder do you want to list?" & vbCr & vbCr _
& "For example: C:\My Documents", _
Default:=Options.DefaultFilePath(wdDocumentsPath))
If x = "" Or x = " " Then
If MsgBox("Either you did not type a folder name correctly" _
& vbCr & "or you clicked Cancel. Do you want to quit?" _
& vbCr & vbCr & _
"If you want to type a folder name, click No." & vbCr & _
"If you want to quit, click Yes.", vbYesNo) = vbYes Then
Exit Sub
Else
GoTo Folder
End If
End If
' Test if folder exists.
If Dir(x, vbDirectory) = "" Then
MsgBox "The folder does not exist. Please try again."
GoTo Folder
End If

[thedark123]

how to use this:

With ActiveDocument.Content.Find
.ClearFormatting
.Style = "Heading 2"


in mulitple documents in a folder?

[thedark123]

Actually the main problem lies here:

For i = 1 To TotalFiles
MyName = .FoundFiles(i)
Documents.Open FileName:=.FoundFiles(i)

counter = -5
For j = 1 To ActiveDocument.Sentences.Count
If ActiveDocument.Sentences(j).Style = "Heading 2" Then
counter = counter + 1
End If
Next j
ActiveDocument.Close

Selection.TypeText MyName & vbTab & FileLen(MyName) _
& vbTab & FileDateTime(MyName) & vbTab & counter & vbLf
Next i


in the very first thread i post, that is my working coding but somehow it will not count the number of heading with style "heading 2"

[thedark123]

here is the screenshot of one of the part in my word document,
ok u see i have multiple tables like this in a document, and in all document there are also several similar tables..

what i got to do is to count the number of tables like this in every document inside tehe specific folder.

can i like do a code to count the number of such string "Test Case ID" and give a total

i wan to do all this using the code that i posted in the first thread


http://i6.photobucket.com/albums/y226/thedark123/Untitled-2.gif

[thedark123]

here will be the result after my above code is done properly which in reality is is working but it is now coding style instead of the string i want

http://i6.photobucket.com/albums/y226/thedark123/results.gif

[thedark123]

this code is working but how do i make the results display in n array format like this?

http://i6.photobucket.com/albums/y226/thedark123/results.gif






Option Explicit

Dim scrFso As Object 'a FileSystemObject
Dim scrFolder As Object 'the folder object
Dim scrSubFolders As Object 'the subfolders collection
Dim scrFile As Object 'the file objectr
Dim scrFiles As Object 'the files objectr

Sub OpenAllFilesInFolder()

'starting place for trav macro
'strStartPath is a path to start the traversal on

Dim strStartPath As String
strStartPath = "C:\Documents and Settings\Administrator\Desktop\isaac"

'stop the screen flickering
Application.ScreenUpdating = False

'open the files in the start folder
OpenAllFiles strStartPath
'search the subfolders for more files
SearchSubFolders strStartPath

'turn updating back on
Application.ScreenUpdating = True

End Sub


Sub SearchSubFolders(strStartPath As String)

'starts at path strStartPath and traverses its subfolders and files
'if there are files below it calls OpenAllFiles, which opens them one by one
'once its checked for files, it calls itself to check for subfolders.

If scrFso Is Nothing Then Set scrFso = CreateObject("scripting.filesystemobject")
Set scrFolder = scrFso.getfolder(strStartPath)
Set scrSubFolders = scrFolder.subfolders
For Each scrFolder In scrSubFolders
Set scrFiles = scrFolder.Files
If scrFiles.Count > 0 Then OpenAllFiles scrFolder.Path 'if there are files below, call openFiles to open them
SearchSubFolders scrFolder.Path 'call ourselves to see if there are subfolders below
Next
End Sub

Sub OpenAllFiles(strPath As String)

' runs through a folder oPath, opening each file in that folder,
' calling a macro called samp, and then closing each file in that folder

Dim strName As String
Dim wdDoc As Document

If scrFso Is Nothing Then Set scrFso = CreateObject("scripting.filesystemobject")
Set scrFolder = scrFso.getfolder(strPath)
For Each scrFile In scrFolder.Files
strName = scrFile.Name 'the name of this file
Application.StatusBar = strPath & "\" & strName 'the status bar is just to let us know where we are
'we'll open the file fName if it is a word document or template
If Right(strName, 4) = ".doc" Or Right(strName, 4) = ".dot" Then
Set wdDoc = Documents.Open(FileName:=strPath & "\" & strName, _
ReadOnly:=False, Format:=wdOpenFormatAuto)

'Call the macro that performs work on the file pasing a reference to it
DoWork wdDoc

'we close saving changes
wdDoc.Close wdSaveChanges
End If
Next

'return control of status bar to Word
Application.StatusBar = False
End Sub

'this is where a macro would be that would actually do something
Sub DoWork(wdDoc As Document)
Dim Count123 As Integer
'ith ActiveDocument.Content.Find
'.ClearFormatting
'.Style = "Heading 2"
'.Text = "Test Case ID"

With Selection.Find

.ClearFormatting
.Text = "Test Case ID"

.Format = True
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False

.Forward = True
'.Wrap = wdFindContinue

Count123 = 0

Do While .Execute(Forward:=True, Format:=True) = True
With .Parent

Count123 = Count123 + 1

If .End = ActiveDocument.Content.End Then
.StartOf Unit:=wdParagraph, Extend:=wdMove
.InsertAfter ":"

Exit Do

Else

.StartOf Unit:=wdParagraph, Extend:=wdMove
.InsertAfter ":"
.Move Unit:=wdParagraph, Count:=1

End If
End With




Loop

MsgBox "There are " & Count123 & " flow."
End With

End Sub