Informationen und Beispiele zum Thema MsgBox | |
---|---|
![]() |
MsgBox-Seite mit Beispielarbeitsmappe aufrufen |
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:
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
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.