Fehler bei worksheet.active abfangen

Public Sub Import_PP4000()
Dim oBook As Excel.Workbook
Dim FileName As String
Dim Aktivfile As String
Dim Openfile As String
Dim oBcb As Object
Dim fs As Object
Dim fls As Object
Dim fldr As Object
Dim sfldr 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
Dim pfadfound As Boolean
Dim strSuchbegriff As String
Application.ScreenUpdating = False
On Error GoTo ErrorImportPP4000
For Each oBcb In UserForm1.MultiPage1.Pages(0).Frame1.Controls
fbfile = oBcb.Caption
Set fs = CreateObject("Scripting.FileSystemObject")
pfadfound = False
If InStr(fbfile, "PP") Then
If fs.folderexists("Q:\PP\") = True Then
StrPfad = "Q:\PP\"
pfadfound = True
End If
If fs.folderexists("P:\PP\") = True And pfadfound = False Then
StrPfad = "P:\PP\"
pfadfound = True
End If
If pfadfound = False Then
StrPfad = ThisWorkbook.Path & "\FB_IBN\"
End If
If fs.folderexists(StrPfad) = False Then MsgBox "Verzeichnis für Vorlage PP  _
nicht gefunden": Exit Sub
Set fldr = fs.getfolder(StrPfad) 'Quellrechner
Set sfldr = fldr.subfolders
Set fls = fldr.Files
If sfldr.Count = 0 And fls.Count = 0 Then
MsgBox "Verzeichnis für Vorlage PP ist leer"
Exit Sub
End If 'sfdl
End If 'fs.folderexist
'            End If 'fs.folderexist q
If InStr(fbfile, "FB") Then
pfadfound = False
If fs.folderexists("Q:\FB\") = True Then
StrPfad = "Q:\FB\"
pfadfound = True
End If
If fs.folderexists("P:\FB\") = True And pfadfound = False Then
StrPfad = "P:\FB\"
pfadfound = True
End If
If pfadfound = False Then
StrPfad = ThisWorkbook.Path & "\FB_IBN\"
End If
If fs.folderexists(StrPfad) = False Then MsgBox "Verzeichnis für Vorlage FB  _
nicht gefunden": Exit Sub
Set fldr = fs.getfolder(StrPfad) 'Quellrechner
Set sfldr = fldr.subfolders
Set fls = fldr.Files
If sfldr.Count = 0 And fls.Count = 0 Then
MsgBox "Verzeichnis für Vorlage FB ist leer"
Exit Sub
End If 'sfldr
End If 'fs.folderexist
'        End If 'fs.folderexist fb_IBN
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
blnFound = False
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
Workbooks(fbfile & ".xls").Worksheets(fbfile).Activate
ActiveSheet.Copy After:=Workbooks(Aktivfile).Sheets(anz)
Workbooks(Aktivfile).Worksheets(fbfile).Activate
ActiveSheet.Name = fbfile
Workbooks(fbfile & ".xls").Close savechanges:=False 'da nicht gespeichert  _
werden soll
'Windows(activefie).Activate
Worksheets(fbfile).Activate
Application.ScreenUpdating = True
End If 'blnfound
End If 'objWks
Next 'obcb
Call PP4000change
ErrorImportPP4000_Exit:
Exit Sub
ErrorImportPP4000:
ErrMess "Import_PP4000", Err.Description
Resume ErrorImportPP4000_Exit
Call DisplayStandardMenu
Application.ScreenUpdating = True
End Sub

Für Tipps bin ich wie immer äußerst Dankbar.
Gruß Jörg