Live-Forum - Die aktuellen Beiträge
Anzeige
Archiv - Navigation
1656to1660
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Geöfnetes Excel-File überspringen

Geöfnetes Excel-File überspringen
26.11.2018 12:52:58
Tom
Hallo zusammen,
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


5
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: temporäre Datei
26.11.2018 17:19:26
Fennek
Hallo,
wenn XL eine Datei öffnet wird eine temporäre Kopie angelegt, die vor dem Dateinamen ein "~$" vorstellt.
Z.B. wird aus ABC.xlsm dan ~$ABC.xlsm. Dies kann man abfragen.
mfg
AW: temporäre Datei
26.11.2018 17:54:56
Tom
Hallo,
ja, das ist richtig, jedoch sind die Dateinamen immer unterschiedlich.
z.B....
C23 3419-3421 LUB 72004   Klein V 3.xlsm
M89 1269-1308 LUB 79177   Regal V 1.xlsm
Gruß Tom
AW: temporäre Datei II
26.11.2018 18:17:40
Fennek
Der Pfad muss angepasst werden:

sub T_1()
f = dir(thisworkbook.path & "\~$*.xls?")
do while len(f)
debug.print f
f = dir
loop
end sub

Anzeige
AW: temporäre Datei II
27.11.2018 12:05:04
Tom
Hallo,
dank Dir....aber ehrlich gesagt weiß ich nicht an welche Stelle des Codes ich Deinen Code setzen soll, damit es berücksichtigt wird. Was meinst Du mit "Der Pfad muss angepasst werden"?
Gruß Tom
AW: Workbooks.Open ?
27.11.2018 12:39:33
Fennek
Hallo,
in einer angemessenen Zeit (ca 3 Minuten) kann ich den Code nicht entziffern: Ein "Workbooks.Open" konnte ich nicht finden. Die Logik wäre vor dem Öffnen eine Abfrage einzufügen:

'f ist der Datei-, Pf der Pfadname
if dir(Pf & "~$" & f)  "" then
workbooks.open(Pf & f)
mfg

93 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige