Habe die Lösung im Auswertungstool implementiert.

Bisher habe ich da nicht durchgeschaut, was der Code genau bedeutet und wo ich in tunen kann.

Folgender Code ändert jetzt die Dateinamen bevor diese für die Tabellenblattbezeichnung verwendet werden.

Besten Dank für die Tipps!!!

Dave

Sub Get_Sheet(PasteAsValues As Boolean, SourceShName As String, _
              SourceShIndex As Integer, myReturnedFiles As Variant)
    Dim mybook As Workbook, BaseWks As Worksheet
    Dim CalcMode As Long
    Dim SourceSh As Variant
    Dim sh As Worksheet
    Dim I As Long
    Dim NeuerName As String

    'Change ScreenUpdating, Calculation and EnableEvents
    With Application
        CalcMode = .Calculation
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
        .EnableEvents = False
    End With

    On Error GoTo ExitTheSub

    'Add a new workbook with one sheet
    Set BaseWks = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
   

    'Check if we use a named sheet or the index
    If SourceShName = "" Then
        SourceSh = SourceShIndex
    Else
        SourceSh = SourceShName
    End If

    'Loop through all files in the array(myFiles)
    For I = LBound(myReturnedFiles) To UBound(myReturnedFiles)
        Set mybook = Nothing
        On Error Resume Next
        Set mybook = Workbooks.Open(myReturnedFiles(I))
        On Error GoTo 0

        If Not mybook Is Nothing Then

            'Set sh and check if it is a valid
            On Error Resume Next
            Set sh = mybook.Sheets(SourceSh)

            If Err.Number > 0 Then
                Err.Clear
                Set sh = Nothing
            End If
            On Error GoTo 0

            If Not sh Is Nothing Then
                sh.Copy After:=BaseWks.Parent.Sheets(BaseWks.Parent.Sheets.Count)

                On Error Resume Next
                
                If mybook.Name Like "*M6201*" Then
                NeuerName = "A10St1"
                ElseIf mybook.Name Like "*M6202*" Then
                NeuerName = "A10St2"
            End If
                
                ActiveSheet.Name = NeuerName
                On Error GoTo 0

                If PasteAsValues = True Then
                    With ActiveSheet.UsedRange
                        .Value = .Value
                    End With
                End If

            End If
            'Close the workbook without saving
            mybook.Close savechanges:=False
        End If

        'Open the next workbook
    Next I

    ' delete the first sheet in the workbook
    Application.DisplayAlerts = False
    On Error Resume Next
    BaseWks.Delete
    On Error GoTo 0
    Application.DisplayAlerts = True

ExitTheSub:
    'Restore ScreenUpdating, Calculation and EnableEvents
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = CalcMode
    End With
    

'ActiveWorkbook.Name = "Aktiv Period Methode"


End Sub