This one may get you intereted

gibbo1715

New Member
Joined
Dec 31, 2004
Messages
31
I have about 10 word docs in a directory, they are the only docs in that directory



Is it possible to search the text in those docs from excel and if the word is found add the document name to an excel spreadsheet



Many Thanks if you figure this one out
 

Excel Facts

Fastest way to copy a worksheet?
Hold down the Ctrl key while dragging tab for Sheet1 to the right. Excel will make a copy of the worksheet.

tusharm

MrExcel MVP
Joined
May 28, 2002
Messages
11,029
Code:
Option Explicit
'Need a reference to MS Scripting Runtime
Sub Initialize(ByRef WDApp As Object, ByRef IStartedWord As Boolean, _
        OutputCell As Range)
    On Error Resume Next
    Set WDApp = GetObject(, "word.application")
    On Error GoTo 0
    If WDApp Is Nothing Then
        IStartedWord = True
        Set WDApp = CreateObject("word.application")
        End If
    Set OutputCell = Workbooks.Add().Worksheets.Add().Range("a1")
    End Sub
Sub Shutdown(WDApp As Object, IStartedWord As Boolean)
    On Error Resume Next
    If IStartedWord Then
        WDApp.Quit
        End If
    Set WDApp = Nothing
    End Sub
Function getFileList(aDir As String) As Scripting.Files
    Dim x As Scripting.FileSystemObject, aFolder As Scripting.Folder
    Set x = New Scripting.FileSystemObject
    Set aFolder = x.GetFolder(aDir)
    Set getFileList = aFolder.Files
    End Function
Function TokenFound(aFile As Scripting.File, _
        ByVal SearchToken As String, WDApp As Object)
    Dim x As Object
    If InStr(1, aFile.Type, "Microsoft word document", vbTextCompare) <= 0 Then
        TokenFound = False
        Exit Function
        End If
    Set x = WDApp.documents.Open(aFile.Path)
    With x.Content.Find
    .ClearFormatting
    .Replacement.Text = ""
    .Forward = True
    '.Wrap = wdFindContinue
    .Format = False
    .MatchCase = False
    .MatchWholeWord = False
    .MatchWildcards = False
    .MatchSoundsLike = False
    .MatchAllWordForms = False
    TokenFound = .Execute(SearchToken)
        End With
    x.Close False
    End Function
Sub AddThisFile(ByRef OutputCell As Range, aFile As Scripting.File)
    OutputCell.Value = aFile.Name
    Set OutputCell = OutputCell.Offset(1, 0)
    End Sub
Sub Main()
    Const DirToSearch As String = "c:\test\", _
        SearchToken As String = "microsoft"
    Dim FileList As Scripting.Files, aFile As Scripting.File, _
        OutputCell As Range, _
        WDApp As Object, IStartedWord As Boolean
    Initialize WDApp, IStartedWord, OutputCell
    Set FileList = getFileList(DirToSearch)
    For Each aFile In FileList
        If TokenFound(aFile, SearchToken, WDApp) Then
            AddThisFile OutputCell, aFile
            End If
        Next aFile
    Shutdown WDApp, IStartedWord
    'OutputCell.Parent.Activate
    End Sub
 

Forum statistics

Threads
1,147,679
Messages
5,742,575
Members
423,738
Latest member
AshleyKitsune

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top