Wenn Ordner leer Mappe schliessen
06.11.2007 08:33:00
volker
im folgenden makro werden Daten aus Mappen eines bestimmten Ordners ausgelesen.
Kann mir jemand das makro so erweitern, dass das makro abgebrochen wird und das Workbook wieder geschlossen wird wenn in dem Ordner keine Dateien zur Verfügung stehen?
Das wäre toll, Vielen Dank Gruss volker
Sub auto_open()
'Zeileneinlesen()
If Cells(2, 5) = 0 Then
Dim oFS As Object, oFLDR As Object, oFILE As Object
Dim lRow As Long
Dim wkbMy As Workbook, wsMy As Worksheet, lngZeile As Long, lngLetzte As Long
Application.ScreenUpdating = False
'Application.DisplayAlerts = False
Set oFS = CreateObject("scripting.filesystemobject")
lRow = 2
Set oFLDR = oFS.getfolder("\\Server04\av\SharePoint_Beschlagliste\Pulk")
For Each oFILE In oFLDR.Files
If oFILE Like "*.xls" Or oFILE Like "*.xlsm" Or oFILE Like "*.xlsx" Then
lRow = lRow
Set wkbMy = Workbooks.Open(oFILE)
For Each wsMy In wkbMy.Worksheets
If wsMy.Name Like "BL_*" Then
Dim wsMyZeile As Long, wsMyletzte As Long
wsMyletzte = wsMy.Cells(Rows.Count, 1).End(xlUp).Row
For wsMyZeile = 5 To wsMyletzte
If wsMy.Cells(wsMyZeile, 1) "" Then
wsMy.Range("A" & wsMyZeile & ":B" & wsMyZeile).Copy
ThisWorkbook.Worksheets(1).Cells(lRow, 5).PasteSpecial Paste:= _
xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
wsMy.Range("G" & wsMyZeile & ":N" & wsMyZeile).Copy
ThisWorkbook.Worksheets(1).Cells(lRow, 7).PasteSpecial Paste:= _
xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
wsMy.Range("AA" & wsMyZeile & ":AD" & wsMyZeile).Copy
ThisWorkbook.Worksheets(1).Cells(lRow, 1).PasteSpecial Paste:= _
xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
wsMy.Range("AE" & wsMyZeile & ":AF" & wsMyZeile).Copy
ThisWorkbook.Worksheets(1).Cells(lRow, 13).PasteSpecial Paste:= _
xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
lRow = lRow + 1
End If
Next wsMyZeile
End If
Next
wkbMy.Close False
''Kill wkbMy ' Befehl für das löschen der Datei
End If
Next
Speicher = "SharePoint_Beschlagliste"
Pfad = "\\Server04\av\SharePoint_Beschlagliste"
DName = Speicher
Dateiname = Pfad & "\" & DName & "_" & Date & ".xls"
ThisWorkbook.SaveAs Filename:=Dateiname
End If
Application.ScreenUpdating = True
'Application.DisplayAlerts = True
End Sub