Microsoft Excel

Herbers Excel/VBA-Archiv

Bewerten Sie hier bitte das Excel-Portal
Auftragsprogrammierung: Nehmen Sie hier Kontakt auf
Informationen und Beispiele zum Thema MsgBox
BildScreenshot zu MsgBox MsgBox-Seite mit Beispielarbeitsmappe aufrufen

Suche nach jüngster Datei


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.