Hallo excelfreunde,
mit dem untenstehenden Makro öffne ich eine bestimmte Exceldatei.
Das such Kriterium steht in der aktuellen Spalte Zeile 43.
gern möchte ich das Makro so erweitern, das wenn keine entsprechende Datei gefunden wird soll die zuletzt gespeicherte Datei geöffnet werden.
Die Dateien liegen mit der Bezeichnung Beispiel vor 30.03.2023.xlsx.
Sub SearchFile()
Dim arr As Variant
Dim iCounter As Integer
Dim sPath As String
Dim wb As Workbook
With Application
.ScreenUpdating = False
'.EnableEvents = False
' '.Calculation = xlCalculationManual
'.Calculation = xlAutomatic
End With
' Suche nach Dateiname in Zeile 45 der aktiven Spalte
Dim sFileName1 As String
' Dim sFileName2 As String
'sFileName = Cells(45, ActiveCell.Column).Value & ".xlsx"
'MsgBox sFileName
If Tabelle21.Range("a1") = "zib" Then
sFileName1 = Format(Cells(43, ActiveCell.Column).Value, "dd.mm.yyyy") & ".xlsx"
Else
sFileName1 = "B" & Format(Cells(43, ActiveCell.Column).Value, "dd.mm.yyyy") & ".xlsx"
End If
'sFileName2 = Format(Cells(43, ActiveCell.Column).Value, "dd.mm.yyyy") & ".xlsx"
'MsgBox sFileName
If Tabelle21.Range("a1") = "zib" Then
sPath = Tabelle8.Range("a2").Value ' startverzeichnis
Else
sPath = Tabelle8.Range("a1").Value
End If
arr = InUnterVerzSuchen(sPath, "*.xls*", vbNormal)
For iCounter = 1 To UBound(arr)
If Dir(arr(iCounter)) = sFileName1 Then
On Error Resume Next
Set wb = Workbooks.Open(Filename:=arr(iCounter), ReadOnly:=True)
wb.tabelle2.Activate
If wb Is Nothing Then
Set wb = Workbooks.Open(Filename:=arr(iCounter), ReadOnly:=False)
wb.tabelle2.Activate
End If
On Error GoTo 0
' Datei schreibgeschützt öffnen, wenn sie von einem anderen Nutzer geöffnet wurde
If Err.Number = 1004 Then
Set wb = Workbooks.Open(Filename:=arr(iCounter), ReadOnly:=True, Notify:=False)
wb.tabelle2.Activate
End If
Exit For
End If
Next iCounter
If wb Is Nothing Then
MsgBox "Datei wurde nicht gefunden"
Else
' MsgBox "Die Fundstelle: " & wb.FullName
End If
With Application
.ScreenUpdating = True
'.EnableEvents = False
' '.Calculation = xlCalculationManual
'.Calculation = xlAutomatic
End With
End Sub
Public Function InUnterVerzSuchen(VerzPfad As String, DateiTyp As String, Attrib As Integer)
Dim VerzName As String, DateiName As String, VerzListe() As String, DateiNr As Integer
Dim VerzNr As Integer, DateiListe() As String, TempListe, Nr As Integer
If Right$(VerzPfad, 1) = "\" Then
DateiName = Dir$(VerzPfad & DateiTyp, Attrib)
Else
DateiName = Dir$(VerzPfad & "\" & DateiTyp, Attrib)
End If
DateiNr = 0
While DateiName > vbNullString
If (DateiName > ".") And (DateiName > "..") Then
DateiNr = DateiNr + 1
ReDim Preserve DateiListe(1 To DateiNr)
DateiListe(DateiNr) = VerzPfad & "\" & DateiName
End If
DateiName = Dir$()
Wend
' Liste mit Unterverzeichnissen erstellen
VerzNr = 0
VerzName = Dir$(VerzPfad & "\", Attrib Or vbDirectory)
While VerzName > vbNullString
If (VerzName > ".") And (VerzName > "..") Then
' Handelt es sich um ein Verzeichnis ?
If GetAttr(VerzPfad & "\" & VerzName) And vbDirectory Then
VerzNr = VerzNr + 1
ReDim Preserve VerzListe(1 To VerzNr)
VerzListe(VerzNr) = VerzName
End If
End If
VerzName = Dir$() ' Nächsten Datei- oder Verzeichnisnamen holen
Wend
' Rekursiver Aufruf, um Unterverzeichnisse zu durchsuchen
For VerzNr = 1 To VerzNr
TempListe = InUnterVerzSuchen(VerzPfad & "\" & VerzListe(VerzNr), DateiTyp, Attrib)
If IsArray(TempListe) Then
For Nr = LBound(TempListe) To UBound(TempListe)
DateiNr = DateiNr + 1
ReDim Preserve DateiListe(1 To DateiNr)
DateiListe(DateiNr) = TempListe(Nr)
Next Nr
End If
Next VerzNr
If DateiNr = 0 Then InUnterVerzSuchen = False Else InUnterVerzSuchen = DateiListe()
End Function
Zu diesen Zweck habe ich auch schon einige Beispiele im Netz gefunden. z.B.
sub neuste_version_starten
Dim AktuellstesDatum As Date
Dim NeuesteDatei As String
Dim FS As Object
Dim Drv As Object
Dim Datei As Object
AktuellstesDatum = DateValue("1.1.2023")
NeuesteDatei = ""
Set FS = CreateObject("scripting.filesystemobject")
Set Drv = FS.GetFolder("R:\test\")
For Each Datei In Drv.Files
If Datei.DateLastModified >= AktuellstesDatum Then
NeuesteDatei = Datei.Name
AktuellstesDatum = Datei.DateLastModified
End If
Next Datei
MsgBox NeuesteDatei
Dieser Code funktioniert zwar aber er hat das Problem das er nur in den einen angegebenen Ordner sucht. Ich muss aber in allen Unterordnern nach der aktuellsten Datei suchen. Das Startverzeichnis steht hier sPath = Tabelle8.Range("a2").Value ' startverzeichnis
Ich dachte mir das ich dann diesen Code mit "call" an dieser Stelle
If wb Is Nothing Then
call neuste_version_starten
'MsgBox "Datei wurde nicht gefunden"
Else
' MsgBox "Die Fundstelle: " & wb.FullName
End If
Aber egal was ich versuche es klappt nicht.
Kann jemand von euch diese Funktionalität in meinen Code einbauen?
Habt schon mal rechtvielen dank für euer Interesse.
mfg thomas