Hallo Mase,

Danke für die Rückmeldung

Da ich nicht so fit in Excel VBA bin und den Code mir aus Einzelteilen gebastelt habe, stehe ich aufm Schlauch.

Folgend sieht man, dass ich die SplitFunktiom Zeile dazugefügt habe, aber es passiert trotzdem nichts. Es kommt auch keine Fehlermeldung. 

Wenn du drüber schauen könntest und mir den Fehler zeigen, wäre es echt nett, da ich in VBA ein richtiger Anfänger bin.

Freundliche Grüße

Axl

Der Code:

Option Explicit
Sub Ubertragung()

    'Neues Excel Objekt
    'Dim objExcel As New Excel.Application
    'Sheet Objekt der jeweiligen Exceldatei
    Dim objSheet As Object
    Dim shZ As Worksheet
    'Hilfsvariablen
    Dim iRow As Long, j As Long, I As Long

    Dim strDateipfad As String
    Dim strPfad As String
    Dim strDateiname As String
    Dim Wb As Workbook, WbZ As Workbook
    
Application.ScreenUpdating = False

    Set WbZ = ThisWorkbook
    Set shZ = WbZ.Worksheets(1)  '<=== anpassen !!!! "1" Index 1 ist die erste Arbeitstabelle / erstes Arbeitsblatt

    'Pfad in welchem die Dateien der zu
    'kopierenden Zellen sich befinden auswählen
    strPfad = ThisWorkbook.Path & Application.PathSeparator
    'Schleife welche den Zelleninhalt aller aufgelisteten
    'Dateien in mehrere Zellen des Hauptprogramms schreibt

    For iRow = 4 To Cells(Rows.Count, 4).End(xlUp).Row
        'Überprüfen, ob in Spalte "Dateiname" bzw "PSP-Element" ein solcher eingetragen ist.
        '(der Arbeitsvorgang wird fortgesetzt)
        
        If shZ.Cells(iRow, 2) = "" Then '= "" Then 'Wenn Zelle in Spalte B Leer dann Exit
            Exit Sub
        Else
            strDateiname = Split(shZ.Cells(iRow, 2), "_")(0)       ' <====  Erstes Element auslesen?
            strDateipfad = strPfad & strDateiname & ".xlsm"    '

            'Überprüfen, ob die in der Tabelle angegebene Datei vorhanden ist.
            '(der Arbeitsvorgang wird fortgesetzt)
            If Len(Dir(strDateipfad)) Then
                If isFileOpen(strDateipfad) Then
                shZ.Cells(iRow, 3) = "nicht aktuell"
            Else
            Cells(iRow, 3) = "aktuell"

                Set Wb = Workbooks.Open(strDateipfad, ReadOnly:=True)
                Set objSheet = Wb.Sheets("Schnittstelle")                   '<==== Schnittstelle

                  For I = 1 To Sheets.Count
                  ActiveWorkbook.Worksheets(I).Unprotect Password:="KKI"    'optional Schreibschutz aufheben

                For j = 7 To 27
                   shZ.Cells(iRow, j) = objSheet.Cells(j + 19, 2)
                Next j
                    ActiveWorkbook.Worksheets(I).Protect Password:="KKI"
                Next I

                Wb.Close saveChanges:=False

                Set Wb = Nothing: Set objSheet = Nothing
            End If
          End If
        End If
Nxt_File:
    Next iRow
Set WbZ = Nothing: Set shZ = Nothing

Verknuepfung

Application.ScreenUpdating = True

End Sub