AW: Dateiname aus Zelle öffnen
16.10.2016 17:48:21
fcs
Hallo Gerhard,
ich hatte nicht bemerkt, dass die Bezeichnungen der Unterordner auch anders als Jahreszahlen sein können.
Hier jetzt dass Ganze angepasst, so dass die Datei in allen Unterordnern gesucht wird.
Die Liste der Unterordner wird dabei nur beim öffnen der 1. Datei erstellt und in einer Variablen gespeichert. Das beschleunigt ggf. das Öffnen weiterer Dateien.
Sollten in der Übersicht in Spate B identische Dateinamen vorkommen, dann wird immer die 1. gefundene Datei geöffnet. Du müsstest deine Liste auf doppelte prüfen und die Dateinamen ggf. anpassen.
LG
Franz
'Code in einem allgemeinen VBA-Modul der Datei
Option Explicit
Public plFolder As Long, parrFolders() As String
Sub ListFoldersInFolder(ByVal SourceFolderName As String, _
Optional IncludeSubfolders As Boolean = False, _
Optional FolderName As Boolean = False)
'1.Parameter Ordner, wo soll gesucht werden?
'2.Parameter mit Unterordner = True, Optional False ist ohne
'3.Parameter kompl. Pfad ausgeben = True, Optional nur Ordnername = False
'Erstellt ein Array mit den Unterordnern - optional inkl. Pfad
Dim FSO As Object, SourceFolder As Object, SubFolder As Object
Dim FileItem
Set FSO = CreateObject("Scripting.FileSystemObject")
Set SourceFolder = FSO.GetFolder(SourceFolderName)
On Error GoTo Err_Zugriff: 'sollte Ordner geschützt sein
For Each FileItem In SourceFolder.subFolders
plFolder = plFolder + 1
ReDim Preserve parrFolders(1 To plFolder)
parrFolders(plFolder) = IIf(FolderName, FileItem, FileItem.Name)
Next FileItem
If IncludeSubfolders Then
For Each SubFolder In SourceFolder.subFolders
ListFoldersInFolder SubFolder.Path, IncludeSubfolders, FolderName
Next SubFolder
End If
Err_Zugriff:
Set FileItem = Nothing: Set SourceFolder = Nothing: Set FSO = Nothing
End Sub
Sub MessdatenDateiOeffen()
Dim wks As Object
Dim strPfadQM As String
Dim strPfadOrdner As String
Dim strPfadDatei As String
Dim strDatei As String
Dim strJahr As String
Dim Zelle As Range
Dim bolDatei As Boolean
Dim bolPfad As Boolean
Dim arrOrdner, intOrdner As Integer
Dim wkb As Workbook
Set wks = ActiveSheet
If wks.Name = "Übersicht" Then 'Blattname ggf. anpassen
Set Zelle = ActiveCell
If Zelle.Row >= 2 And Zelle.Column = 2 And Zelle "" Then
bolPfad = False
bolDatei = False
strPfadQM = "D:\Messdaten\QM\"
If Dir(Left(strPfadQM, Len(strPfadQM) - 1), vbDirectory) = "" Then
MsgBox "Pfad" & vbLf & strPfadQM & vbLf & "existiert nicht"
Exit Sub
End If
strDatei = Zelle.Text
strJahr = Left(strDatei, 4)
If IsNumeric(strJahr) Then
'Suche in dem Unterverzeichnis mit dem aus dem Dateinamen ermittelten Jahr
strPfadOrdner = strPfadQM & strJahr
bolPfad = Dir(strPfadOrdner, vbDirectory) ""
If bolPfad = True Then
strPfadDatei = strPfadOrdner & "\" & strDatei
bolDatei = Dir(strPfadDatei) ""
End If
End If
If bolDatei = False Or bolPfad = False Then
'Datei in allen Ordnern suchen
If plFolder = 0 Then
'Liste der Ordner wird einmalig nach dem Öffnen der Datei erstellt
Call ListFoldersInFolder(SourceFolderName:=Left(strPfadQM, Len(strPfadQM) - _
1), _
IncludeSubfolders:=True, _
FolderName:=True)
End If
For intOrdner = 1 To plFolder
strPfadOrdner = parrFolders(intOrdner)
If Dir(strPfadOrdner & Application.PathSeparator & strDatei) "" Then
bolPfad = True
bolDatei = True
strPfadDatei = strPfadOrdner & "\" & strDatei
Exit For
End If
strPfadOrdner = ""
Next
End If
If bolDatei = True Then
'Messdatendatei schreibgeschützt öffnen"
Set wkb = Application.Workbooks.Open(strPfadDatei, ReadOnly:=True)
'Variable wkb verwenden, wenn mit der Datei weitere Aktionen durchgeführt _
werden sollen.
Else
MsgBox "Die Datei " & vbLf & strDatei & vbLf _
& "wurde nicht gefunden!"
End If
Else
MsgBox "Bitte vor dem Start des Makros eine Zelle in Spalte B " _
& "mit einem Dateinamen selektieren!"
End If
Else
MsgBox "Dieses Makro ""MessdatenDateiOeffnen"" nur ausführen, wenn " _
& "Blatt ""Übersicht"" aktiv ist."
End If
End Sub
