Suche nach jüngster Datei

Hallo ihr lieben,
ich habe ein Makro was nach einer Bestimmten Datei sucht.
Klappt Super!
Da wir mit Projekten Arbeiten, die stätigt vorangetrieben werden hätte ich gerne das Makro erweiter für den Abgleich: Suche die Datei Nimm aber das jüngste Datum.
Geschriebenes Makro:
strProject = "Ansicht - Projektplanzeilen - " & Projekte & FILE_EXTENSION 'Anpassen !!!
Set objFileSystemObject = CreateObject("Scripting.FileSystemObject")
Set objDrives = objFileSystemObject.Drives
For Each objDrive In objDrives
With objDrive
If .IsReady Then
If InStr(.ShareName, DRIVE_NAME) größer 0 Then
blnFoundDrive = True
strPath = String$(MAX_PATH, vbNullChar)
lngReturn = SearchTreeForFile(.DriveLetter & ":\", strProject, strPath)
If lngReturn größerkleiner 0 Then
blnFoundFile = True
strPath = Left$(strPath, InStr(1, strPath, vbNullChar) - 1)
Exit For
End If
End If
End If
End With
Next
If blnFoundDrive Then
If blnFoundFile Then
Set objWorkbook = Workbooks.Open(Filename:=strPath)
ThisWorkbook.Activate
strFile = Right(strPath, Len(strPath) - InStrRev(strPath, "\"))
Danke für eure Mühe vorab.

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Public Sub Projekt() Const DRIVE_NAME As String = "\\10.3.1.1\Projekte" Const FILE_EXTENSION As String = "*.xlsx" Dim objFileSystemObject As Object, objDrives As Object, objDrive As Object Dim objWorkbook As Workbook Dim blnFoundDrive As Boolean, blnFoundFile As Boolean Dim strPath As String, strProject As String Dim lngReturn As Long Dim Projekte As String Projekte = Worksheets(1).Cells(5, 7) strProject = "Ansicht - Projektplanzeilen - " & Projekte & FILE_EXTENSION 'Anpassen !!! Set objFileSystemObject = CreateObject("Scripting.FileSystemObject") Set objDrives = objFileSystemObject.Drives For Each objDrive In objDrives With objDrive If .IsReady Then If InStr(.ShareName, DRIVE_NAME) > 0 Then blnFoundDrive = True strPath = String$(MAX_PATH, vbNullChar) lngReturn = SearchTreeForFile(.DriveLetter & ":\", strProject, strPath) If lngReturn 0 Then blnFoundFile = True strPath = Left$(strPath, InStr(1, strPath, vbNullChar) - 1) Exit For End If End If End If End With Next If blnFoundDrive Then If blnFoundFile Then Set objWorkbook = Workbooks.Open(Filename:=strPath) ThisWorkbook.Activate strFile = Right(strPath, Len(strPath) - InStrRev(strPath, "\")) Workbooks(strFile).Close savechanges:=False Set objWorkbook = Nothing Else Call MsgBox("Datei nicht gefunden.", vbCritical, "Fehler") End If Else Call MsgBox("Laufwerk nicht gefunden.", vbCritical, "Fehler") End If Set objDrive = Nothing Set objDrives = Nothing Set objFileSystemObject = Nothing End Sub

Hallo Tina,
teste mal:

Option Explicit

Private Declare PtrSafe Function SearchTreeForFile Lib "dbghelp.dll" ( _
    ByVal RootPath As String, _
    ByValputPathName As String, _
    ByValputPathBuffer As String) As Long

Public Sub Test()

    Const FILE_EXTENSION As String = ".xlsx"
    Const DRIVE_NAME As String = "\\10.3.1.1\Projekte"
    Const MAX_PATH As Long = 260&

    Dim avntTemp As Variant
    Dim strProject As String, Projekte As String, strPath As String
    Dim strFile As String, strFolder As String, strFilename As String
    Dim lngReturn As Long, lngMaxNumber As Long
    Dim blnFoundDrive As Boolean, blnFoundFile As Boolean
    Dim objFileSystemObject As Object, objDrives As Object
    Dim objDrive As Object
    Dim objWorkbook As Workbook
    Dim objCollection As Collection

    Projekte = Worksheets(1).Cells(5, 7).Value

    strProject = "Ansicht - Projektplanzeilen - " & Projekte & FILE_EXTENSION

    Set objFileSystemObject = CreateObject(Class:="Scripting.FileSystemObject")
    Set objDrives = objFileSystemObject.Drives

    For Each objDrive In objDrives

        With objDrive

            If .IsReady Then

                If InStr(.ShareName, DRIVE_NAME) > 0 Then

                    blnFoundDrive = True
                    strPath = String$(MAX_PATH, vbNullChar)
                    lngReturn = SearchTreeForFile(.DriveLetter & ":\", strProject, strPath)

                    If lngReturn <> 0 Then

                        blnFoundFile = True
                        strPath = Left$(strPath, InStr(1, strPath, vbNullChar) - 1)
                        Exit For

                    End If
                End If
            End If
        End With
    Next

    If blnFoundDrive Then
        If blnFoundFile Then

            Set objCollection = New Collection

            strFolder = Mid$(strPath, 1, InStrRev(strPath, "\"))
            strFilename = Dir$(strFolder & "Ansicht - Projektplanzeilen - " & Projekte & "*." & FILE_EXTENSION)
            Do Until strFilename = vbNullString
                If InStr(1, strFilename, "(") Then
                    avntTemp = Split(strFilename, "(")
                    avntTemp = Split(avntTemp(1), ")")
                    lngMaxNumber = Application.Max(lngMaxNumber, Clng(avntTemp(0)))
                    Call objCollection.Add(Item:=strFilename, Key:=CStr(avntTemp(0)))
                End If
                strFilename = Dir$
            Loop

            If objCollection.Count > 0 Then _
                strPath = strFolder & objCollection.Item(Index:=CStr(lngMaxNumber))

            Set objCollection = Nothing

            Set objWorkbook = Workbooks.Open(Filename:=strPath)

            'warum sofort wieder schließen?

            objWorkbook.Close savechanges:=False

            Set objWorkbook = Nothing
        Else
            Call MsgBox("Datei nicht gefunden.", vbCritical, "Fehler")
        End If
    Else
        Call MsgBox("Laufwerk nicht gefunden.", vbCritical, "Fehler")
    End If
End Sub

Gruß
Nepumuk

Option Explicit Public jüngsteDatei As Object Public jüngstesDatum As Date Public ws As Worksheet Public zeile As Long Sub Datei_suchen() Dim col As Range Dim dauer As Single Dim drv As Object Dim fso As Object Dim letzteZeile As Long Dim rootFol As Object Dim strProject As String dauer = Timer strProject = "Ansicht - Projektplanzeilen - 2019" & ".xlsx" Set ws = ThisWorkbook.Worksheets(1) letzteZeile = ws.UsedRange.SpecialCells(xlCellTypeLastCell).Row If letzteZeile jüngstesDatum Then jüngstesDatum = fil.DateLastModified Set jüngsteDatei = fil ws.Cells(zeile, "A") = jüngstesDatum ws.Cells(zeile, "B") = Datei ws.Cells(zeile, "C") = fil.Path zeile = zeile + 1 End If End If Next fil For Each subfol In Verzeichnis.SubFolders FolderAbarbeiten subfol, Datei Next subfol Exit Sub FehlerBeh: Exit Sub End Sub

Beliebteste Forumthreads (12 Monate)

8 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

8
Beiträge zum Forumthread

Beiträge zu diesem Forumthread