Betrifft: Suche nach jüngster Datei
von: Tina
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
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
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
Betrifft: AW: Suche nach jüngster Datei
von: Tina richter
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
Betrifft: AW: Suche nach jüngster Datei
von: Tina