Ordner durchsuchen, einschl. Unterordner

Hajo_Zi · 2018-09-04T07:04:01+00:00

Hallo, es geht um Version 2016, die nicht ausgewählt werden kann. Ich glaube dies muss über eine Funktion gelöst werden. Ich habe einen Dateinamen z.B. 140E5111 Diese Datei mus in einem Ordner einschl. Unterordner gesucht werden. Hinter den Dateinamen muss aber [1] stehen. Wobei ich die höchste Zahl benötige. Es darf keine Datei mit einem Zusatz gesucht werden z.B. "BAK_140E5111" Es sollen folgende Dateitypen gesucht werden - PDF - SLDPRT - DXF - Steep Der Funktion würde ich den Dateinamen und den Dateityp übergeben. Ich benötige den Ablageort einschl. dem kompletten Dateinamen. Gruß Hajo

Hallo
Code mit Filterkriterien


Sub MyMain()
Const myPath = "C:\Users\Downloads\"
Const myName = "3662555379"
Const myType = "pdf"
Dim fso As Object
Dim startFolder As Object
Dim foundFile As String
Dim foundVersion As Long
Set fso = CreateObject("Scripting.FileSystemObject")
Set startFolder = fso.getfolder(myPath)
If startFolder Is Nothing Then
Debug.Print "Folder " & myPath & " does'nt exist ..."
Else
foundFile = ""
foundVersion = 0
Call GetFiles(startFolder, myName, myType, foundFile, foundVersion)
Debug.Print foundFile
End If
End Sub
Sub GetFiles(folder As Object, seaName As String, seaType As String, foundFile As String,  _
foundVersion As Long)
Dim subFolder As Object
Dim allFiles As Object
Dim myFile As Object
Dim splitArray() As String
Dim myVersion As Long
For Each subFolder In folder.subfolders
Call GetFiles(subFolder, seaName, seaType, foundFile, foundVersion)
Next
Set allFiles = folder.Files
For Each myFile In allFiles
splitArray = Split(myFile.Name, ".")   ' hier wird Dateiname/Dateityp getrennt
If UCase(splitArray(UBound(splitArray))) = UCase(seaType) Then
' wir haben den richtigen Dateityp
If UCase(seaName) = Mid(UCase(splitArray(LBound(splitArray))), 1, Len(seaName)) Then
' wir haben den richtigen Dateinamen und ermitteln die Version
splitArray = Split(myFile.Name, "[")
If UBound(splitArray) > 0 Then
splitArray = Split(splitArray(UBound(splitArray)), "]")
myVersion = CInt(splitArray(LBound(splitArray)))
If myVersion > foundVersion Then
foundVersion = myVersion
foundFile = myFile.Path
End If
End If
End If
End If
Next
End Sub

Hi
geht in allen Versionen, sollte sich auch einfach in eine Funktion umschreiben lassen:

Sub DateiSuche()
'Spezial;Dateien suchen
Dim StartPfad As String
Dim Pfade() As String
Dim SuchDatei As String
Dim SuchTyp As String
Dim Dateien() As String
Dim Datei As String
Dim Pos1 As Long, Pos2 As Long, x As Long
Dim Mx As Long
Dim Erg As String
Dim txt As String
Dim D
'--- Startpfad und Suchstring eingeben
StartPfad = "C:\Daten\"
SuchDatei = "140E5111[*]*"
SuchTyp = "PDF,SLDPRT,DXF,STEEP"
If Right(StartPfad, 1)  "\" Then StartPfad = StartPfad & "\"
If Dir(Left(StartPfad, Len(StartPfad) - 1), vbDirectory) = "" Then MsgBox "Startpfad nicht  _
vorhanden": Exit Sub
'--- Unterpfade ermitteln, Datei suchen -----------
ReDim Pfade(0)
ReDim Dateien(0)
Pfade(0) = StartPfad
Pos1 = 0
Pos2 = UBound(Pfade)
Do
For x = Pos1 To Pos2
Datei = Dir(Pfade(x), vbDirectory)
Do While Datei Like ".*"
Datei = Dir
Loop
Do While Datei  ""
If Len(Pfade(x) & Datei)  0 Then
Dateien(UBound(Dateien)) = Pfade(x) & Datei
ReDim Preserve Dateien(UBound(Dateien) + 1)
End If
Case Else
End Select
End If
Datei = Dir
Loop
Next
Pos1 = Pos2 + 1
Pos2 = UBound(Pfade)
Loop While Pos1  0 Then
For Each D In Dateien
If D  "" Then
txt = Mid(D, InStr(D, "[") + 1)
txt = Left(txt, InStr(txt, "]") - 1)
If Val(txt) > Mx Then
Mx = Val(txt)
Erg = D
End If
End If
Next
End If
MsgBox Erg
End Sub

nicht getestet
Gruß Daniel

Ordner durchsuchen, einschl. Unterordner

Forumthread: Ordner durchsuchen, einschl. Unterordner

32
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Ordner durchsuchen, einschl. Unterordner

Forumthread: Ordner durchsuchen, einschl. Unterordner

32 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu diesem und ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

32
Beiträge zum Forumthread

Beiträge zu diesem Forumthread