Geöfnetes Excel-File überspringen
26.11.2018 12:52:58
Tom
der Code liest unter einem festzugteilten Laufwerk alle darin abgelegten Excel-Dateien aus und legt die Inhalte ab. Wenn jedoch einer der Dateien geöffnet ist, bricht die Prozedur ab und ich muss warten bis die Date von den Kollegen geschlossen wird.
Meine Idee wäre es, dass die geöffneten Dateien übersprungen werden und das Makro somit weiterarbeitet. Die geöffnete Datei kann dann zu einem späteren Zeitpunkt ausgelesen werden.
Unten folgend der Code. Wie lässt sich das Überspringen integrieren?
Vielen Dank
Tom
Option Explicit ' Variablendfefinition
Dim LogFile As TextStream
Dim FolderCount As Long
Dim FileCount As Long
Dim StOrdner As String ' Variable für Verzeichnis
Dim loletzte As Long ' Zeile in die geschrieben werden soll
Dim StTyp As String ' Dateityp
Dim LoJ As Long ' Variable für Zeile
Private Sub Chk_Datei_schreiben_Click()
Chk_Datei.Visible = Chk_Datei_schreiben
Opt_Datei_getrennt.Visible = Chk_Datei_schreiben
Opt_Datei_Pfad.Visible = Chk_Datei_schreiben
End Sub
Private Sub Chk_Hyperlink_Click()
Opt_Hyperlink_Datei.Visible = Chk_Hyperlink
Opt_Hyperlink_Pfad.Visible = Chk_Hyperlink
End Sub
Private Sub Cmd_Verzeichnis_Click()
StOrdner = "L:\" ' Verzeichnis auswählen
If StOrdner = "" Then
MsgBox "Es wurde kein Ordner ausgewählt!"
Else
StTyp = "XLSM"
End If
End Sub
Private Sub Cmd_Start_Click()
Worksheets("externe Nachträge").Columns("A").EntireColumn.Hidden = False
LoJ = 2
If StOrdner = "" Then
MsgBox "Es wurde kein Ordner ausgewählt"
Exit Sub
End If
Application.ScreenUpdating = False ' Bildschirmaktulalisierung aus
' Zeile aus Originalcode
If Chk_Datei_schreiben = False Then StTyp = "*" ' es sollen nur Verzeichnisse aufgelistet _
_
werden
SearchInFolder StOrdner ' Sub aufrufen
With Worksheets("externe Nachträge")
.Columns("A:F").EntireColumn.AutoFit ' automatische Spaltenbreite
If Chk_Datei_schreiben Then
' Spalte B ausblenden falls nicht benötigt
.Columns("B:B").EntireColumn.Hidden = Not Opt_Datei_getrennt
' Spalte A einblenden falls nicht benötigt
.Columns("A:A").EntireColumn.Hidden = Range("A1") "Datei"
End If
' Spalte E und F ausblenden falls nicht benötigt
.Columns("E:F").EntireColumn.Hidden = Not Chk_Datei
Columns("C:C").ColumnWidth = 43.63
' Tabelle Namen geben
End With
Application.ScreenUpdating = True ' Bildschirmaktualisierung ein
Cmd_Start.Caption = "Start" ' Beschriftung zurücksetzen
Unload Me ' UserForm verlassen
End Sub
Private Sub Cmd_Ende_Click()
End
End Sub
Private Sub SearchInFolder(ByVal Folderspec As String)
' auslesen aufrufen mit Ordnername
Dim FSO As New FileSystemObject
Dim SearchFolder As Folder
Dim FD As Folder, FI As File
Dim EachFil As Files, EachFold As Folders
Dim LoI As Long ' Laufvariable zum schreiben der Ordner
Dim RaFound As Range ' Variable Suchergebnis
Set SearchFolder = FSO.GetFolder(Folderspec)
Set EachFil = SearchFolder.Files ' Dateien in der jeweiligen Root
If Chk_Unter Then ' Unterverzeichnis ausgewählt
' für Unterverzeichnis
Set EachFold = SearchFolder.SubFolders ' Unterordner in der Root
DoEvents ' andere Befehle ausführen
' Unterordner des Verzeichnisses feststellen und in Datei schreiben
With Worksheets("externe Nachträge")
For Each FD In EachFold
SearchInFolder CStr(FD) ' Funktion rekursiv aufrufen weitere _
Unterverzeichnisse
Next FD
End With
' ***** es sind alle Verzeichnisse aufgelistet
End If
With Worksheets("externe Nachträge")
loletzte = IIf(IsEmpty(.Cells(.Rows.Count, 1)), .Cells(Rows.Count, 1).End(xlUp).Row, . _
_
Rows.Count) + 1
' Dateien auslesen
' Dateiname schreiben
If Chk_Datei_schreiben Or Chk_Hyperlink Then
For Each FI In EachFil ' Schleife über alle Dateien
' Ergänzung Hajo
' Dateityp feststellen
If UCase(Right(FI.Name, Len(FI.Name) - InStrRev(FI.Name, "."))) = UCase(StTyp) _
_
Or StTyp = "" Or StTyp = "*" Then
' überprüfen ob schon vorhanden in Spalte A
Set RaFound = .Columns(1).Find(FI, , , xlPart, , xlNext)
If RaFound Is Nothing Then
' nicht vorhanden
' Darstellungsart
If Chk_Hyperlink = True Then ' Hyperlink ausgewählt
If Opt_Hyperlink_Datei Then
' Hyperlink nur Dateiname
ActiveSheet.Hyperlinks.Add Anchor:=.Cells(loletzte, 3), _
Address:=FI.Path, TextToDisplay:=FI.Name
Else
' Hyperlink Pfad und Dateiname
ActiveSheet.Hyperlinks.Add Anchor:=.Cells(loletzte, 3), _
Address:=FI.Path, TextToDisplay:=FI.Path
End If
End If
If Chk_Datei_schreiben Then
If Opt_Datei_Pfad Then
' Dateiname einschl. Ordner
.Cells(loletzte, 1) = FI.Path
.Cells(loletzte, 6) = Now
Else
' Dateiname ohne Ordner
.Cells(loletzte, 1) = FI.Name
' Pfad
.Cells(loletzte, 2) = Left(FI.Path, Len(FI.Path) - Len(FI.Name)) _
_
End If
End If
If Chk_Datei Then
If Chk_Datei = True Then ' Dateigröße und Speicherdatum ausgewä _
_
hlt
.Cells(loletzte, 5) = FI.DateLastModified
If .Cells(loletzte, 2) .Cells(loletzte - 1, 2) And loletzte > _
_
2 _
And StTyp = "*" And Chk_Datei = True Then
If LoJ = 2 Then
LoJ = loletzte
End If
End If
End If
loletzte = loletzte + 1 ' Zeilenzähler um 1 erhöhen
Cmd_Start.Caption = loletzte ' Programmfortschritt anzeigen
End If
End If
' ********
DoEvents
Next FI
If StTyp = "*" And Chk_Datei = True Then
End If
Else
' werden nur Verzeichnisse geschrieben beginnt die Liste in Zeile 1, keine Ü _
berschrift
.Cells(1, 1).Font.Bold = False
End If
End With
Set EachFil = Nothing
Set EachFold = Nothing
Set FSO = Nothing
Set RaFound = Nothing
End Sub