Search Word!

All files (*.doc) of a selectable folder - with subfolders - ar scanned for a term. If the term is found, the files are linked and listed. The files at the end of the article are Excelfiles of the version 2003 and 2007.

The following code belonged in "Module1"

Option Explicit
Private Declare Function GetCurrentDirectory Lib "kernel32" _
Alias "GetCurrentDirectoryA" _
(ByVal nBufferLength&, ByVal lpBuffer$) As Long
Private Declare Function SetCurrentDirectory Lib "kernel32" _
Alias "SetCurrentDirectoryA" _
(ByVal lpPathName$) As Long
Const strSearchTMP As String = "Calculation"
Const strEXT As String = "*.doc"
Private strList() As String
Private objWDApp As Object
Private lngCount As Long
Private objFSO As Object
Public Sub Test()
Dim strListing As String
Dim strDirOld As String
lngCount = 0
On Error GoTo Fin
strDirOld$ = String(255, 0)
Call GetCurrentDirectory(255, strDirOld$)
strDirOld$ = Left(strDirOld$, _
InStr(1, strDirOld$, vbNullChar) - 1)
If funcDirectory(strListing) <> "" Then
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objWDApp = CreateObject("Word.Application")
SearchFiles strListing, strEXT
If lngCount = 0 Then
MsgBox "No file with the search value found."
With Tabelle1 ' anpassen!!!
.Range(.Cells(1, 1), Cells(lngCount, 1)) = _
End With
Call HyLink(Tabelle1)
End If
End If
If Not objWDApp Is Nothing Then objWDApp.Quit
Call SetCurrentDirectory(strDirOld$)
Set objWDApp = Nothing
Set objFSO = Nothing
End Sub
Private Sub SearchFiles(strFolder As String, strFileName As String)
Dim objFolder As Object
Dim objFile As Object
For Each objFile In objFSO.GetFolder(strFolder).Files
If objFile.Name Like strFileName Then
objWDApp.Documents.Open objFile.Path
With objWDApp.Selection.Find
.Forward = True
.Text = strSearchTMP
If .Execute = True Then
Redim Preserve strList(lngCount)
strList(lngCount) = objFile.Path
lngCount = lngCount + 1
objWDApp.ActiveDocument.Close False
End If
End With
End If
For Each objFolder In objFSO.GetFolder(strFolder).Subfolders
SearchFiles strFolder & "\" & objFolder.Name, strFileName
End Sub
Private Function funcDirectory(strDirectory As String) As String
With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = "C:\"
.Title = "Directory"
.ButtonName = "Select..."
.InitialView = msoFileDialogViewList
If .Show = -1 Then
strDirectory = .SelectedItems(1)
If Right(strDirectory, 1) <> "\" _
Then strDirectory = strDirectory & "\"
funcDirectory = strDirectory
funcDirectory = ""
End If
End With
End Function
Private Sub HyLink(objSheet As Object)
Dim lngRow As Long
With objSheet
lngRow = .Range("A" & .Rows.Count).End(xlUp).Row
For lngRow = 1 To lngRow
.Hyperlinks.Add Anchor:=.Cells(lngRow, 2), _
Address:=.Cells(lngRow, 1), _
TextToDisplay:=Mid(.Cells(lngRow, 1), _
InStrRev(.Cells(lngRow, 1), "\", -1) + 1)
Next lngRow
End With
End Sub

Sample 2003

Sample 2007


Beliebte Posts aus diesem Blog

Formeln - auch Array - per VBA eintragen...

Alle Dateien eines Ordners - Optional mit Unterordner

Excel -> Word in Textmarken (Bookmarks)...