Option Explicit
Sub DateienLesen()
    Call EventsOff
    Dim DateiName As String, Meldung As String
    DateiName = Dir("C:\Temp\" & "*.xls")
    Do While DateiName <> ""
        If ThisWorkbook.Name <> DateiName And SheetExists("" & Mid(DateiName, 1, 8)) = False Then
            Workbooks.Open Filename:="C:\Temp\" & DateiName
            Workbooks(DateiName).Worksheets("Tabelle1").Copy After:=Workbooks(ThisWorkbook.Name).Worksheets(Sheets.Count)
            ActiveSheet.Name = Mid(DateiName, 1, 8)
            Workbooks(DateiName).Close
        Else
            Meldung = MsgBox("Ein Worksheet mit dem Namen " & Mid(DateiName, 1, 8) & " gibt es schon")
        End If
        DateiName = Dir
    Loop
    Call EventsOn
End Sub

Public Sub EventsOff()
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        .Calculation = xlCalculationManual
    End With
End Sub

Public Sub EventsOn()
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = xlCalculationAutomatic
    End With
End Sub

Public Function SheetExists(strName As String) As Boolean
    On Error Resume Next
    SheetExists = Not Worksheets(strName) Is Nothing
End Function

Sub Start()
Dim WbZiel As Workbook
Dim WbQuelle As Workbook
Dim WsQuelle As Worksheet
Dim strPfad As String
Dim strDat As String
Dim i As Integer

Application.ScreenUpdating = False
Application.EnableEvents = False

'Importdatei:
   Set WbZiel = ThisWorkbook

'Quellpfad anbeben:
   strPfad = "Q:\FLPS Toolbox\Dokumente Berichtemanager\Test"

'Backslash:
   strPfad = IIf(Right(strPfad, 1) <> "\", strPfad & "\", strPfad)

'Importdateien:
   strDat = Dir(strPfad & "*.xls")

'Schleife über alle Dateien des Ordners
   Do While strDat <> ""
      Set WbQuelle = Workbooks.Open(Filename:=strPfad & strDat, ReadOnly:=True)
         For Each WsQuelle In WbQuelle.Worksheets  'Schleife über alle Tabellenblätter
            i = i + 1
            WsQuelle.Copy After:=WbZiel.Sheets(WbZiel.Sheets.Count)
            a = Right(WsQuelle.Parent.Name, Len(WsQuelle.Parent.Name) - InStr(WsQuelle.Parent.Name, "_"))
            b = Right(a, Len(a) - InStr(a, "_"))
            c = Right(b, Len(b) - InStr(b, "_"))
            d = Right(c, Len(c) - InStr(c, "_"))
            e = Right(d, Len(d) - InStr(d, "_"))
            f = Left(e, InStr(e, " "))
            ActiveSheet.Name = (f)
         Next
         WbQuelle.Close savechanges:=False
      If i Mod 200 = 0 Then
         WbZiel.Save
      End If
      strDat = Dir()
   Loop
    
Application.EnableEvents = True
Application.ScreenUpdating = True
Set WbZiel = Nothing
Set WbQuelle = Nothing
Set WsQuelle = Nothing
'End Sub

'Sub ProfitcenterName()
Dim wksL As Worksheet
Dim wksR As Worksheet

Set wksL = ActiveWorkbook.Worksheets(1)
Set wksR = ActiveWorkbook.Worksheets(6)
            a = wksR.Range("C7").Value
            b = Right(a, Len(a) - InStr(a, "/"))
            c = Right(b, Len(b) - InStr(b, "/"))
            d = Right(c, Len(c) - InStr(c, "/"))
            NameFertig = Left(d, InStr(d, "/") - 1)
wksL.Range("C6").Value = NameFertig

'End Sub


'Sub Fenster_fixieren()
    

'End Sub
    
'Sub Tabelle verschieben()

    Sheets(i + 3).Move Before:=Sheets("PC-DUMMY")
    
' End Sub

'Sub Tabelle löschen()

    Application.DisplayAlerts = False
    Sheets("PC-DUMMY").Delete
    Application.DisplayAlerts = True

'End Sub

'Sub Blattschutz()

If ThisWorkbook.Worksheets(1).ProtectContents = True Then
  For Each wks In ThisWorkbook.Worksheets
    'wks.Unprotect Password:="**"
  Next 'wks
Else
  For Each wks In ThisWorkbook.Worksheets
    wks.Protect Password:="**"
  Next 'wks
End If

    Dim wb As Workbook
    Dim NeuerName As String
    
    Set wb = ActiveWorkbook
    Set ws = ActiveSheet
       
    NewName = NameFertig
    With ActiveWorkbook
        .SaveAs "Q:\ControlK\Wirtschaftspläne\WiPl2010+2011\Planungsdateien\GuV\" & NewName, wb.FileFormat
        '.Close
    End With
    wb.Activate
    Kill "Q:\FLPS Toolbox\Dokumente Berichtemanager\Test\*.xls"
    Workbooks.Open Filename:="Q:\FLPS Toolbox\Dokumente Berichtemanager\Masterdateien\Profitcenterknoten.xls", ReadOnly:=False
End Sub