Das Archiv des Excel-Forums

Suche nach jüngster Datei

Suche nach jüngster Datei von Tina vom 26.09.2019 12:18:50

AW: Suche nach jüngster Datei - von Nepumuk am 26.09.2019 15:37:49

AW: Suche nach jüngster Datei - von Tina am 27.09.2019 11:19:29

AW: Suche nach jüngster Datei - von Nepumuk am 27.09.2019 14:40:16

AW: Suche nach jüngster Datei - von Tina richter am 01.10.2019 12:36:33

AW: Suche nach jüngster Datei - von Nepumuk am 01.10.2019 14:02:39

AW: Suche nach jüngster Datei - von Tina richter am 01.10.2019 16:59:49

AW: Suche nach jüngster Datei - von Dieter Klemke am 26.09.2019 21:01:29

AW: Suche nach jüngster Datei - von Tina am 27.09.2019 11:22:08

Betrifft: Suche nach jüngster Datei
von: Tina

Geschrieben am: 26.09.2019 12:18:50

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.

Betrifft: AW: Suche nach jüngster Datei
von: Nepumuk
Geschrieben am: 26.09.2019 15:37:49
Hallo Tina,
befinden sich die Dateien im selben Ordner in dem auch die von dem Makro gefundene Datei liegt? Woran kann die jüngste Datei erkannt werden? (z.B. Datum im Dateinamen?)
Gruß
Nepumuk

Betrifft: AW: Suche nach jüngster Datei
von: Tina

Geschrieben am: 27.09.2019 11:19:29
Hallo Nepumuk,
die Datei ist im gleichen Verzeichnis im gleichen Unterordner mit gleichen Namen außer die Endung ist dann (1) und fortlaufend Hochgezählt.

Betrifft: AW: Suche nach jüngster Datei
von: Nepumuk
Geschrieben am: 27.09.2019 14:40:16
Hallo Tina,
kannst du bitte den kompletten Code posten, dann muss ich nicht alle Deklarationen nachbauen.
Gruß
Nepumuk

Betrifft: AW: Suche nach jüngster Datei
von: Tina richter

Geschrieben am: 01.10.2019 12:36:33
Hallo Nepumuk,
entschuldige die verspätete Antwort. Privat geht es gerade drunter und drüber.
Unten stehend der Code. Würde eh mal behaupten der ist von dir :)
Option Explicit
Private Declare PtrSafe Function SearchTreeForFile Lib "imagehlp.dll" ( _
ByVal RootPath As String, _
ByVal InputPathName As String, _
ByVal OutputPathBuffer As String) As Long
Private Const MAX_PATH As Long = 260&
Public strFile As String
Public strPath As String

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

Betrifft: AW: Suche nach jüngster Datei
von: Nepumuk
Geschrieben am: 01.10.2019 14:02:39
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









Betrifft: AW: Suche nach jüngster Datei



von: Tina richter









Geschrieben am: 01.10.2019 16:59:49


Leider kann ich ihn erst nächste Woche testen.


Aber er sieht genauso gut aus wie der andere :)


Natürlich wird sie nicht gleich wieder geschlossen.


Den Abgleich/ Kopieren der Daten erfolgt vor dem Schließen, aber diesen kann ich erst jetzt einbauen. Muss auch noch absprechen ob alle Daten übernommen werden soll oder nur ein Teil :)


1000 dank dir.


LG


Tina















Betrifft: AW: Suche nach jüngster Datei



von: Dieter Klemke



Geschrieben am: 26.09.2019 21:01:29


Hallo Tina,


ich habe mal ein vorhandenes Programm etwas angepasst:
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 < 2 Then letzteZeile = 2
ws.Rows(2).Resize(letzteZeile - 1).ClearContents
zeile = 2
jüngstesDatum = DateSerial(Year:=1750, Month:=1, Day:=1)
Set fso = CreateObject("Scripting.FileSystemObject")
For Each drv In fso.Drives
If drv.IsReady Then
Set rootFol = drv.RootFolder
FolderAbarbeiten rootFol, strProject
End If
Next drv
Set fso = Nothing
dauer = Timer - dauer
MsgBox Prompt:="Jüngste Datei:" & vbNewLine & _
jüngsteDatei.Path & vbNewLine & _
"Zuletzt verändert: " & jüngsteDatei.DateLastModified & vbNewLine & _
"Dauer: " & Format$(dauer, "#,##0") & " Sek."
Application.StatusBar = Empty
End Sub
Sub FolderAbarbeiten(Verzeichnis As Object, _
Datei As String)
Dim fil As Object
Dim i As Long
Dim subfol As Object
Application.StatusBar = Left$(Verzeichnis.Path, 255)
' Prüfen, ob Zugriff zu dem Verzeichnis "Verzeichnis" besteht
' (z.B. besteht kein Zugriff auf den Ordner
'  "C:\System Volume Information")
' Falls kein Zugriff möglich ist, wird der Ordner übergangen.
On Error GoTo FehlerBeh
i = Verzeichnis.Files.Count
On Error GoTo 0
' Es besteht Zugriff auf das Verzeichnis fol
For Each fil In Verzeichnis.Files
If fil.Name = Datei Then
If fil.DateLastModified > 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



Wenn du mehrere Platten in Betrieb hast, kann das natürlich dauern.


In der Statuszeile siehst du jeweils das aktuell in Berabeitung befindliche Verzeichnis.


https://www.herber.de/bbs/user/132224.xlsm



Viele Grüße


Dieter









Betrifft: AW: Suche nach jüngster Datei



von: Tina








Geschrieben am: 27.09.2019 11:22:08


Hallo Dieter,


danke für deine Mühe, aber welches Verzeichnis gerade abgearbeitet wird ist mir völlig egal.


Mir ist wichtig, dass der Start des Projektes nicht berührt wird und wir so sehen können wie das Projekt wächst und welche Fehler auftauchen, damit wir auch lernen können.


Daher ist es mir wichtig, dass die Kollegen auch die neue Datei einfach in Ihren Ordner legen und das Programm im Excel starten.


Somit muss mein Programm wissen was ist die jüngste Datei.