For Each Checkbox und stop nach letzen Durchlauf
27.05.2008 09:35:00
Jörg
ich habe eine Funktionen zum Importieren von Mappen geschrieben.
Hier soll für jede aktive Checkbox in einer Multipage die entsprechende
Mappe kopiert werden.
Mein Problem hierbei ist , das die Funktion immer einmal mehr als gewünscht
durchlaufen wird und ich immer eine Mappe(2) bekomme.
Lasse ich nun die Zeile "On Error Next " weg, so erhalte ich immer nach dem letzen Import
einen Laufzeitfehler 438....
Hier aber erstmal der Code:
Public Sub Import_PP4000()
Dim FileName As String
Dim Aktivfile As String
Dim Openfile As String
Dim ObCb As Object
Dim fs As Object
Dim anz As Byte
Dim strDateiName As String, StrPfad As String
Dim FBFile As String
'Abfrage Tabellen existent
Dim objWks As Worksheet
Dim blnFound As Boolean
For Each ObCb In UserForm1.MultiPage1.Pages(0).Controls
FBFile = ObCb.Caption
Set fs = CreateObject("Scripting.FileSystemObject")
If InStr(FBFile, "PP") Then
If fs.folderexists("Q:\PP\") = True Then
StrPfad = "Q:\PP\"
Else
StrPfad = ThisWorkbook.Path & "\PP\"
If fs.folderexists(StrPfad) = False Then
MsgBox "Verzeichnis für Vorlage FB/PP nicht gefunden"
Exit Sub
End If
End If
End If
If InStr(FBFile, "FB") Then
If fs.folderexists("Q:\FB\") = True Then
StrPfad = "Q:\FB\"
Else
StrPfad = ThisWorkbook.Path & "\FB_IBN\"
If fs.folderexists(StrPfad) = False Then
MsgBox "Verzeichnis für Vorlage FB/PP nicht gefunden"
Exit Sub
End If
End If
Application.ScreenUpdating = False
On Error Resume Next 'Fehler abfangen
If InStr(FBFile, "FB") And ObCb.Value = True Or InStr(FBFile, "PP") And ObCb.Value = True Then
'If ObCb.Value = True Then
For Each objWks In Worksheets
If objWks.Name = FBFile Then blnFound = True: Exit For
Next
If Not blnFound Then 'wenn die Tabelle nicht vorhanden, dann weitermachen
strDateiName = StrPfad & FBFile & ".xls"
Openfile = strDateiName
Aktivfile = ActiveWorkbook.Name
anz = ActiveWorkbook.Sheets.Count
Workbooks.Open FileName:=Openfile
'MsgBox "geöffnete Datei " & Openfile
Workbooks(FBFile & ".xls").Worksheets("Tabelle1").Activate
ActiveSheet.Copy after:=Workbooks(Aktivfile).Sheets(anz)
Workbooks(Aktivfile).Worksheets("Tabelle1").Activate
ActiveSheet.Name = FBFile
Workbooks(FBFile & ".xls").Close savechanges:=False 'wenn gespeichert werden _
soll
Windows(Aktivfile).Activate
End If 'blnfound
End If 'objWks
End If ' Instr
Application.ScreenUpdating = True
Next
End Sub
Wo liegt hier der Fehler und wie kann ich es unterbinden?
Danke schon mal für eure Antworten.....
LG Jörg