Application.FileSearch in Office 2007?

Question

Hallo,

das folgende Programm, war dazu da, in unserer Firma, einen markierten Bereich in einer Exceltabelle durchzugehen und dann in einem vorher angegebenen Ordner, nach Dateien des selben Names zu suchen.
Ich hoffe ihr könnt mir helfen, da derjenige der das Makro geschrieben hat, nicht mehr hier ist und nun ich diese Aufgabe bekommen habe.

Mit freundlichen Grüßen
Christian Edel

P.S.: Hier das Makro:
Und schonmal VIELEN DANKE für die Hilfe!!!!

Sub VerknüpfungenErstellen_V3()
Dim pfad As String
'in welchem Verzeichnis liegen die Dokumente?
Dim oSh As Object
Dim oFd As Variant
Dim nS As Object

Set oSh = GetObject("", "Shell.Application")
Set oFd = oSh.BrowseforFolder(0, _
"Bitte ein Verzeichnis auswählen ...", 0, "")
Set nS = oFd.Self
pfad = nS.Path

Set oSh = Nothing


If pfad = "" Then Exit Sub

'Markierte Zellen durchgehen
For Each cell In Selection

gefunden = False



With Application.FileSearch
.NewSearch
.LookIn = pfad
.SearchSubFolders = True
.Filename = cell.Value & ".pdf"
.MatchTextExactly = True
.FileType = msoFileTypeAllFiles

If .Execute() > 0 Then
Select Case .FoundFiles.Count
Case 1
'Verknüpfen
'MsgBox "LINK: " & .FoundFiles(1)
ActiveSheet.Hyperlinks.Add cell, .FoundFiles(1)
gefunden = True
Case Else
MsgBox "Es wurde mehr ale eine passende Datei " & cell.Value & ".pdf gefunden. Bitte manuell verknüpfen."
End Select
Else
'MsgBox "Es wurde keine Datei " & cell.Value & ".pdf gefunden."
End If
End With

If Not (gefunden) Then
'mit verkürztem Suchstring (ohne führende Nullen) nochmal durchgehen, falls nichts gefunden wurde.
'Beispiel cell.Value = DE000004006420C5
' suchstring = DE4006420C5
suchstring = cell.Value
While Mid(suchstring, 3, 1) = "0" And Not (gefunden)

'eine Null entfernen..
suchstring = Left(suchstring, 2) & Right(suchstring, Len(suchstring) - 3)

'..und nochmal suchen
With Application.FileSearch
.NewSearch '
.LookIn = pfad
.SearchSubFolders = True
.Filename = suchstring & ".pdf"
.MatchTextExactly = True
.FileType = msoFileTypeAllFiles

If .Execute() > 0 Then
Select Case .FoundFiles.Count
Case 1
'Verknüpfen
'MsgBox "LINK: " & .FoundFiles(1)
ActiveSheet.Hyperlinks.Add cell, .FoundFiles(1)
gefunden = True
Case Else
MsgBox "Es wurde mehr ale eine passende Datei " & suchstring & ".pdf gefunden. Bitte manuell verknüpfen."
End Select
Else
MsgBox "Es wurde keine Datei " & suchstring & ".pdf gefunden."
End If
End With

Wend
End If

Next

End Sub

Answer 1

Er bleibt immer hier hängen:
Set SearchFolder = FSO.GetFolder(Folderspec)
Mit der Fehlermeldung
Laufzeitfehler 5, ungültiger Prozeduraufruf oder ungültiges Argument

Answer 2

Ach mist falscher Code sorry ...

der richtige:

Option Explicit
Dim FolderCount As Long
Dim FSO As New FileSystemObject
Dim FileCount As Long
' Variable für Verzeichnis
Dim nS As Object
Dim StOrdner As String
Const StTyp As String = "*.PDF" ' Dateityp
Dim RaFound As Range ' Variable Suchergebnis

Sub Start()
Application.ScreenUpdating = True ' Bildschirmaktulalisierung aus
SearchInFolder StOrdner ' Sub aufrufen
Application.ScreenUpdating = True ' Bildschirmaktualisierung ein
End Sub

Private Sub SearchInFolder(ByVal Folderspec As String)
Dim oSh As Object
Dim oFd As Variant
Set oSh = GetObject("", "Shell.Application")
Set oFd = oSh.BrowseforFolder(0, _
"Bitte ein Verzeichnis auswählen ...", 0, "")
Set nS = oFd.Self
Set oSh = Nothing
StOrdner = nS.Path

Dim FSO As New FileSystemObject
Dim SearchFolder As Folder
Dim FD As Folder, FI As File
Dim EachFil As Files, EachFold As Folders
Set SearchFolder = FSO.GetFolder(Folderspec)
Set EachFil = SearchFolder.Files ' Dateien in der jeweiligen Root
' für Unterverzeichnis
Set EachFold = SearchFolder.SubFolders ' Unterordner in der Root
' Unterordner des Verzeichnisses feststellen und in Datei schreiben
For Each FD In EachFold
' Funktion rekursiv aufrufen weitere Unterverzeichnisse
SearchInFolder CStr(FD)
Next FD
' Dateien auslesen
For Each FI In EachFil ' Schleife über alle Dateien
' Prüfen ob Dateiname im Bereich
Set RaFound = Selection.Find(FI.Name, , , xlWhole, xlByRows, xlNext)
If Not RaFound Is Nothing Then
' Datei gefunden
' Hyperlink erstellen
If Range(RaFound.Address).Hyperlinks.Count = 0 Then
ActiveSheet.Hyperlinks.Add Anchor:=Range(RaFound.Address), _
Address:=FI.Path, TextToDisplay:=FI.Name
End If
Else
Set RaFound = Selection.Find(Left(FI.Name, 2) & "0000" & Mid(FI.Name, 3), , , _
xlWhole, xlByRows, xlNext)
If Not RaFound Is Nothing Then
If Range(RaFound.Address).Hyperlinks.Count = 0 Then
ActiveSheet.Hyperlinks.Add Anchor:=RaFound, _
Address:=FI.Path, TextToDisplay:=FI.Name
End If
End If
End If
Next FI
Set EachFil = Nothing
Set EachFold = Nothing
Set FSO = Nothing
Set RaFound = Nothing
End Sub

Answer 3

Hallo christian,

ich hätte ja als erstes den unveränderten Code (nur Ordner angepast) getestet bevor ich was verändere: Der Code lief bei mir. Fragen dazu kann Ich erst am Abend beantworten.

Gruß hajo

Answer 4

Hi,

@C.Edel
Deine Umsetzung aus #20 funktioniert im Grossen und Ganzen. Du hast dort mMn den Dialog zur Verzeichnissuche an genau der richtigen Stelle eingebunden. Nur geht Hajo in seinem Code davon aus, dass in den Zellen in Selection der DateiName incl. der Extension zu finden ist. Schreibe in einer Testtabelle einmal ein .pdf hinter den Dateinamen, und starte den Code aus #20. Dann sollte es auch den ein oder anderen Link geben. (So habe ich es zumindest getestet.)

Der Versuch mit dem Code aus #22 hingegen muss fehlschlagen. Du rufst in Start die Sub SearchInFolder ohne Argument auf. Somit ist die Variable Folderspec ein leerer String. Es wird also aus Set SearchFolder = FSO.GetFolder(Folderspec) => Set SearchFolder = FSO.GetFolder(""). Und das kann so nicht funktionieren, da die GetFolder-Methode dort den Pfad zu einem existierenden Verzeichnis zwingend erfordert.

btw:
[*] Werden Unterverzeichnisse nun benötigt?
[*] Wenn ja, wie stellst Du Dir die Auswahl bei Mehrfach-Treffern in verschiedenen Verzeichnissen vor? Oder traust Du Dir eine entsprechende Anpassung des Codes selbst zu?
[*] Was soll passieren, wenn schon ein Link existiert? Wenn ich den Code bisher richtig interpretiere, macht der Code von Hajo mit einer Zelle (mit Link) nichts, egal ob ein entsprechendes File existiert oder nicht.

Bye
malSchauen

Answer 5

Hallo,

ich habe nun ein bisschen weitergebastelt, und mein Code macht nun schon das, was ich will, jedoch habe ich ein Problem.

Meine Dateien heißen - DE000010031991B4.pdf
In meinen Zellen steht - DE000010031991B4

Mir fehlt bzw ist dieses .pdf zu viel.
Ich habe noch keine Stelle im Programm gefunden, wo ich das korrigieren kann.
Sobald ich ein .pdf in meinen Zellen anhäng funktioniert es

Answer 6

Hallo malSchaunen,

vielen Dank. Ja bei mir funktioniert das auch, sobald ich ein .pdf anhänge. Und ich suche krampfhaft nach einer Möglichkeit, das zu umgehen.
Ich habe bereits versucht mit :

For Each cell In Selection
ActiveCell.Value = ActiveCell.Value & ".pdf"
ActiveCell.Offset(1, 0).Range("A1").Select
Next

Mein Problem ist aber dann, dass er meine markierung verliert und nicht mehr weiß, was er alles ändern soll.
Es geht um Patentrecht, demnach gehe ich davon aus, dass es die gleiche Datei nicht Doppelt gibt.
Mein Problem ist, ich würde mir nicht zutrauen das selber abzufangen ^^

Hier nochmal mein aktuellster Code:

Option Explicit
Dim FolderCount As Long
Dim FSO As New FileSystemObject
Dim FileCount As Long ' Variable für Verzeichnis
Dim RaFound As Range ' Variable Suchergebnis

Sub Verlinkung_v4_Office2007()
Application.ScreenUpdating = False ' Bildschirmaktualisierung aus
Dim StOrdner As String
Dim oSh As Object
Dim oFd As Variant
Dim nS As Object
Set oSh = GetObject("", "Shell.Application")
Set oFd = oSh.BrowseforFolder(0, _
"Bitte ein Verzeichnis auswählen ...", 0, "") 'Pfad übergeben
Set nS = oFd.Self
Set oSh = Nothing
StOrdner = nS.Path

If StOrdner = "" Then Exit Sub


SearchInFolder StOrdner ' Sub aufrufen
Application.ScreenUpdating = True ' Bildschirmaktualisierung ein
End Sub

Private Sub SearchInFolder(ByVal Folderspec As String)
Dim SearchFolder As Folder
Dim FSO As New FileSystemObject
Dim FD As Folder, FI As File
Dim EachFil As Files, EachFold As Folders
Set SearchFolder = FSO.GetFolder(Folderspec)
Set EachFil = SearchFolder.Files ' Dateien in der jeweiligen Root
' für Unterverzeichnis
Set EachFold = SearchFolder.SubFolders ' Unterordner in der Root
' Unterordner des Verzeichnisses feststellen und in Datei schreiben
For Each FD In EachFold
' Funktion rekursiv aufrufen weitere Unterverzeichnisse
SearchInFolder CStr(FD)
Next FD
' Dateien auslesen
For Each FI In EachFil ' Schleife über alle Dateien
' Prüfen ob Dateiname im Bereich
Set RaFound = Selection.Find(FI.Name, , , xlWhole, xlByRows, xlNext)
If Not RaFound Is Nothing Then
' Datei gefunden
' Hyperlink erstellen
If Range(RaFound.Address).Hyperlinks.Count = 0 Then
ActiveSheet.Hyperlinks.Add Anchor:=Range(RaFound.Address), _
Address:=FI.Path
End If
Else
Set RaFound = Selection.Find(Left(FI.Name, 2) & "0000" & Mid(FI.Name, 3), , , _
xlWhole, xlByRows, xlNext)
If Not RaFound Is Nothing Then
If Range(RaFound.Address).Hyperlinks.Count = 0 Then
ActiveSheet.Hyperlinks.Add Anchor:=RaFound, _
Address:=FI.Path
End If
End If
End If
Next FI

Cells.Replace What:=".pdf", Replacement:="", LookAt:=xlPart, SearchOrder _
:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False ' ".pdf" löschen

Set EachFil = Nothing
Set EachFold = Nothing
Set FSO = Nothing
Set RaFound = Nothing
End Sub

Gruß
Christian

Answer 7

SOOOOOOOOOOOOOOOOOOOOO
Nun habe ich es geschafft. Ein bisschen getrickst, aber es macht das, was ich will :)

Ich habe noch ein Problem, aber da muss ich erst klären ob das uns zum Problem werden kann.
Aus irgenteinem Grund, bricht der das untersuchen von Unterordnern ab sobald er eine Datei findent.
Auch wenn im Überordner Dateien sind, nimmt er zuerst den Unterordner, also etwas spanisch.
Aber wenn alle in einem Ordner sind isses perfekt.

Hier mein fertiger Code:

Option Explicit
Dim FolderCount As Long
Dim FSO As New FileSystemObject
Dim FileCount As Long ' Variable für Verzeichnis
Dim RaFound As Range ' Variable Suchergebnis

Sub Verlinkung_v4_Office2007()
Application.ScreenUpdating = False ' Bildschirmaktualisierung aus
Dim cell As Range
For Each cell In Selection
ActiveCell.Value = ActiveCell.Value & ".pdf"
ActiveCell.Offset(1, 0).Range("A1").Select
Next

Range("A:Z").Select

Dim StOrdner As String
Dim oSh As Object
Dim oFd As Variant
Dim nS As Object
Set oSh = GetObject("", "Shell.Application")
Set oFd = oSh.BrowseforFolder(0, _
"Bitte ein Verzeichnis auswählen ...", 0, "") 'Pfad übergeben
Set nS = oFd.Self
Set oSh = Nothing
StOrdner = nS.Path

If StOrdner = "" Then Exit Sub


SearchInFolder StOrdner ' Sub aufrufen
Application.ScreenUpdating = True ' Bildschirmaktualisierung ein
End Sub

Private Sub SearchInFolder(ByVal Folderspec As String)
Dim SearchFolder As Folder
Dim FSO As New FileSystemObject
Dim FD As Folder, FI As File
Dim EachFil As Files, EachFold As Folders
Set SearchFolder = FSO.GetFolder(Folderspec)
Set EachFil = SearchFolder.Files ' Dateien in der jeweiligen Root
' für Unterverzeichnis
Set EachFold = SearchFolder.SubFolders ' Unterordner in der Root
' Unterordner des Verzeichnisses feststellen und in Datei schreiben
For Each FD In EachFold
' Funktion rekursiv aufrufen weitere Unterverzeichnisse
SearchInFolder CStr(FD)
Next FD
' Dateien auslesen
For Each FI In EachFil ' Schleife über alle Dateien
' Prüfen ob Dateiname im Bereich
Set RaFound = Selection.Find(FI.Name, , , xlWhole, xlByRows, xlNext)
If Not RaFound Is Nothing Then
' Datei gefunden
' Hyperlink erstellen
If Range(RaFound.Address).Hyperlinks.Count = 0 Then
ActiveSheet.Hyperlinks.Add Anchor:=Range(RaFound.Address), _
Address:=FI.Path
End If
Else
Set RaFound = Selection.Find(Left(FI.Name, 2) & "0000" & Mid(FI.Name, 3), , , _
xlWhole, xlByRows, xlNext)
If Not RaFound Is Nothing Then
If Range(RaFound.Address).Hyperlinks.Count = 0 Then
ActiveSheet.Hyperlinks.Add Anchor:=RaFound, _
Address:=FI.Path
End If
End If
End If
Next FI

Cells.Replace What:=".pdf", Replacement:="", LookAt:=xlPart, SearchOrder _
:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False ' ".pdf" löschen

Set EachFil = Nothing
Set EachFold = Nothing
Set FSO = Nothing
Set RaFound = Nothing
End Sub

Gruß
C.Edel

Answer 8

Hi,

@C.Edel

...sind isses perfekt.

Von "perfekt" bist Du mit dem Code mMn noch weit entfernt. ;-) Aber da Du Ausdauer beweist, und auch eigene Ideen einbringst, glaube ich zu erkennen, dass Du selbst auch ein klein wenig Spass an der Sache hast. Wenn dem so ist, und Du, wie ich es hier gelesen habe als Azubi, keinen wirklichen Zeitdruck bei der Sache hast, dann können wir gern mit den Denkansätzen zu Deiner eigenen Lösung weitermachen. (Kann beim lernen von VBA, wenn Du denn willst, evtl. hilfreicher sein, als eine laufende "Komplettlösung" die Du evtl. nicht durchschaust.)

[*] zu Deinem Problem mit der Trickserei in der Selection:

Dim cell As Range
For Each cell In Selection
ActiveCell.Value = ActiveCell.Value & ".pdf"
ActiveCell.Offset(1, 0).Range("A1").Select
Next

Range("A:Z").Select

Du musst Dich nicht wundern, ... dass er meine markierung verliert. Du setzt ja mit .Select jeweils eine neue "Markierung". Nun kann man in den allermeisten Fällen auf .Select und auch auf .Activate verzichten. Tipps dazu findest Du z.B. hier. Und um dann auch mal zu sehen und zu durchschauen, was welche Zeile im Code denn für Auswirkungen auf Deine Mappe hat, könnte evtl. dieses Tutorial hilfreich sein.
Um hier dann mal bei Deiner "Trickserei" zu bleiben, schau doch mal was passiert, wenn Du obigen CodeSchnippsel durch folgendes ersetzt:

Dim rngCell As Range
For Each rngCell In Selection
rngCell.Value = rngCell.Value & ".pdf"
Next

' Range("A:Z").Select

Mit For Each sprichst Du in diesem Fall ja schon jede Zelle in der Selection EINZELN an. Du musst sie, um etwas damit anzustellen nun nicht auch noch aktivieren oder selectieren, und Deine ursprüngliche Auswahl sollte erhalten bleiben. (Somit brauchst Du dann auch nicht A:Z komplett selectieren. Daher ist die CodeZeile auskommentiert).

[*] das Nächste

Aus irgenteinem Grund, bricht der das untersuchen von Unterordnern ab sobald er eine Datei findent

Dazu musst Du Dir die "Position" der einzelnen CodeZeilen und deren Auswirkungen im Ablauf mal vor Augen führen. Nun ist es beim rekursiven Aufruf einer Sub bei den ersten Programmier-"Versuchen" für Dich evtl. nicht ganz einfach zu durchschauen, was ich damit meine. Daher möchte ich das an obigem CodeSchnippsel mal deutlich machen:
Du hast mMn eh schon ein Problem mit dem Code aus #27, wenn der User im "Ordner suchen" Dialog auf "Abbrechen" klickt. (Schon mal gemacht?) Du solltest einen Laufzeitfehler ernten (LZF91). Der User hat den Button, und irgendwann klickt da auch mal einer drauf. Für einen Test fang diesen Fehler einmal ab wie folgt:

Set oFd = oSh.BrowseforFolder(0, _
"Bitte ein Verzeichnis auswählen ...", 0, "") 'Pfad übergeben
If oFd Is Nothing Then Exit Sub
Set nS = oFd.Self

Das ist nicht alles, was es abzufangen gilt, für einen Test reicht es aber. Nun wähle Deine Zellen mal aus und starte Dein Makro. Klicke nun bei der OrdnerWahl mal auf "abbrechen". Mach das ganze mal so 2, 3 oder auch 10 mal, und schaue was aus den Werten (Dateinamen) in den ausgwählten Zelle wird.
Nicht so schön, oder?

Beim Unterordner-"Problem" dürfte es ähnlich sein.:
Da

For Each FD In EachFold
' Funktion rekursiv aufrufen weitere Unterverzeichnisse
SearchInFolder CStr(FD)
Next FD

im CodeAblauf vor

For Each FI In EachFil ' Schleife über alle Dateien
' Prüfen ob Dateiname im Bereich
Set RaFound =...

kommt, werden zuerst die Unterverzeichnisse untersucht. Im ersten Unterverzeichnis werden nun die Dateien auf "Treffer" hin untersucht. Treffer in diesem Unterverzeichnis werden wohl auch verlinkt, nehme ich an, ohne es getestet zu haben. Nun sind alle Dateien im Unterverzeichnis durchsucht. Du bist mit Dem Code also gerade im Sub SearchInFolder in der Zeile mit dem Code Next FI. Dabei bist Du im ersten Unterverzeichnis des ausgewählten Verzeichnisses. Und was passiert nun? Mit Cells.Replace What:=".pdf", ... machst Du nun Deine "Trickserei" an dieser Stelle rückgängig. Du entfernst also das .PDF in (mMn ALLEN) Zellen. War es nur ein Untervereichnis, dann durchsuchst Du nun die Dateien im "ausgewählten" Verzeichnis. In Deinen Zellen fehlt nun aber schon wieder das .PDF=> kein Treffer/Link mehr.
Siehe oben: "rekursive Aufrufe" sind anfangs evtl. nicht leicht zu durchschauen, aber besser kann ich es leider nicht erklären.

Aber evtl. hilft es Dir ja, Dich einer EIGENEN Lösung weiter anzunähern, wenn Du denn die Zeit dafür investieren kannst/möchtest. Ist dem nicht so, dann kläre mal die Themen und Rückfragen die bisher auftauchten (Unterverz.?, was soll bei MehrfachTreffern passieren etc.) und es findet sich hier sicher eine Lösung im Forum. Wobei die dann wohl auch keinen Anspruch auf Perfektion haben wird. ;-)

soweit fürs Erste
malSchauen

Answer 9

Hallo malSchauen,

wirklich VIELEN DANK für diese ausführliche aufmunterung.
Wie du richtig bemerkt hast LIEBE ich coden.
Ich habe meine Ausbildung zum 1.9 begonnen und konnte vorher C, VFP, BAT und ein bisschen VB
Ich verbringe fast meine ganze Freihzeit damit :D

Sobald ich morgen in der Firma bin, werdei ch mich mal getreu deiner Anregungen auf die Socken machen

Gruß Christian

Answer 10

Hallo,

jetzt sitze ich wieder in der Firma und starre meinen Code an^^.
Das mit dem Selektieren, ist vollkommen richtig. Wirklich sehr hilfreich dieses kleine Tut.
Aber ich komme nicht wirklich drauf, wie ich mehrfachtreffer abfangen könnte. Zählt vieleicht die Funktion Find() irgentwie hoch wenn sie etwas findet? Dann könnte ich diesen Wert abfragen. Im Falle [Find.Rückgabe]>1 gebe Warunung aus.

Zu dem thema mit de m .pdf. Wahnsinn nachdem ich meinen Code Cells.Replace auskommentiere, nimmt er alle Dateien aus allen Unterordnern. Kann ich vieleicht einfach eine Private Sub schreiben, die ganz am Ende ausgeführt wird?

Vielen Dank für eure umfangreiche HIlfe und das ihr mir den Spaß am "coden" erhalten wollt :)

Gruß Christian