Hallo VBA-Freunde,
ich knoble gerade an einer Verbesserung einer Arbeitsmappe.
Dazu möchte ich gerne den Pfad zu einer bestimmten Datei auf dem Server auslesen lassen.
Die Datei heißt z.B. collectingsheet.xlsm und steht bei mir im Verzeichnis C:\BUCON.
Da müssten eigentlich alle für das Projekt relevanten Dateien drinstehen:
QNT.XLSM
Collectingsheet.xlsm
Smartsheet.xlsm
usw-
Ich möchte nun diese Namen in eine Zelle schreiben und per VBA-Code soll mein Rechner und alle Laufwerksordner in meinem Bereich durchgesucht werden, wo die Datei steht.
Ist das überhaupt möglich?
Vielen Dank für eure Antworten.
Heinz
Hallo Heinz,
hier mal ein Beispielcode. Beschreibung siehe Kommentare. Die Ergebnisse gebe ich zusätzlich nochmal mit dem Dateinamen aus, da der code für mehrere Fundorte einer Datei ausgelegt ist.
Arbeitsblatt mit dem Namen 'Tabelle1' |
| A | B | C |
1 | Suche in: | C:\Test | |
2 | Suchname | Treffername | Treferpfad |
3 | Export.xlsx | Export.xlsx | C:\Test\Mieze |
4 | Daten.zip | Export.xlsx | C:\Test\Theo\Neuer Ordner |
5 | | Daten.zip | C:\Test |
Diese Tabelle wurde mit Tab2Html (v2.5.0) erstellt. ©Gerd alias Bamberg |
DefStr S
DefObj O
Sub FileSearch()
'Variablendeklaration
'String ueber DefStr
Dim strSPath, strFile, strMyMsg
'Integer
Dim iCnt%
'Startpfad festlegen, hier aus Zelle B1 des aktiven Blattes
strSPath = Cells(1, 2)
'Schleife ueber alle Dateien, ab A3 des aktiven Blattes
For iCnt = 3 To Cells(Cells(Rows.Count, 1).End(xlUp).Row, 1).Row
'Filename festlegen
strFile = Cells(iCnt, 1).Value
'Dateisuche beginnen
strMyMsg = f_FileSearch(strSPath, strFile, strMyMsg)
'Ende Schleife ueber alle Dateien, ab A2 des aktiven Blattes
Next
MsgBox "Treffer: " & strMyMsg
End Sub
Function f_FileSearch(strPath, strFile, ByRef strMyMsg) As String
'Verweis auf Microsoft Scripting Runtime setzen
'Variablendeklaration
'FileSystem Objekte
Dim objFSO As New FileSystemObject
Dim objFile As File
'Object ueber DefObj
Dim objDirs As Folder, objFolder As Folder
'Ordner setzen
Set objFolders = objFSO.GetFolder(strPath)
'Schleife fuer rekursive abarbeitung
For Each objFolder In objFolders.SubFolders
'Erneuter Funktionsaufruf mit einem Unterordner
f_FileSearch = f_FileSearch(objFolder.Path, strFile, strMyMsg)
'Ende Schleife fuer rekursive abarbeitung
Next
'Schleife ueber alle Dateien des Ordners / Unterordners
For Each objFile In objFolders.Files
'Wenn der Dateiname dem Suchname entpricht, dann
If objFile.Name = strFile Then
'Ausgabe des Dateinamen und Pfad im Direktfenster
Debug.Print objFile.Name & vbTab & objFile.ParentFolder
'Ausgabe des Pfades an die Funktion
strMyMsg = strMyMsg & vbTab & objFile.ParentFolder
'Ausgabe in eine Zelle des aktiven Blattes ab B2
With Cells(Cells(Rows.Count, 2).End(xlUp).Row + 1, _
Cells(Cells(Rows.Count, 2).End(xlUp).Row + 1, _
Columns.Count).End(xlToLeft).Column + 1)
.Value = objFile.Name
.Offset(0, 1) = objFile.ParentFolder
'Ende Ausgabe in eine Zelle des aktiven Blattes ab B2
End With
'Ende Wenn der Dateiname dem Suchname entpricht, dann
End If
'Ende Schleife ueber alle Dateien des Ordners / Unterordners
Next
'Rueckgabewert zuweisen
f_FileSearch = strMyMsg
End Function