Kill geht nicht
07.11.2007 08:47:00
volker
mit folgendem makro werden Daten aus bestimmten Mapen ausgelesen.
Wenn dies fertig ist. möchte ich diese Mappe aus dem Ursprungsordner löschen.
hier mein komplettes makro.
Laufzeitfehler 438 bei Zeile
.Filename = wkbMyName ' Hier der Dateiname, muss vorher ausgelesen worden sein, z.B.: _
Kann mir jemand helfen?
Danke Gruss volker
Sub auto_open()
'Zeileneinlesen()
If Cells(2, 5) = 0 Then
Dim unterOdner As Variant, dateien As Variant
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
' *Prüfe Inhalt ****************************************************************
Set fs = CreateObject("Scripting.filesystemobject")
Set ordner = fs.getfolder("\\Server04\av\SharePoint_Beschlagliste\Pulk")
unterOdner = ordner.subfolders.Count
dateien = ordner.Files.Count
If (dateien * 1) + (unterOdner * 1) = 0 Then
GoTo Abbruch:
End If
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
wkbMyName = ActiveWorkbook.Name
wkbMy.Close False
'Datei aus Ursprungsordner löschen
Set oFS = CreateObject("scripting.filesystemobject")
Set fs = CreateObject("Scripting.filesystemobject")
Set ordner = fs.getfolder("\\Server04\av\SharePoint_Beschlagliste\Pulk")
With oFS
.Filename = wkbMyName ' Hier der Dateiname, muss vorher ausgelesen _
worden sein, z.B.: _
If .Execute() > 0 Then
For i = 1 To .FoundFiles.Count
Kill .FoundFiles(i)
Next i
End If
End With
''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
Exit Sub
Abbruch:
Application.DisplayAlerts = False
ActiveWorkbook.Close
' Application.Quit
End Sub