Hallo Zusammen,

da ich selbst nicht weiterkomme, möchte ich euch um Hilfe bitten.

Zurzeit sieht es so aus: 

Ich habe eine Hauptdatei + viele Dataein in einem Gesamtverzeichnis. In der Hauptdatei sind die Dateinamen(Nummer) aus diesem Gesamtverzeichnis aufgelistet.

Mein Programm kann zurzeit die aufgelisteten Dateinamen(Nummer) durchlesen und überprüfen, ob diese im Verzeichnis exestieren usw. 

Zum Problem: 

Da es geschickter ist, die Dateinamen(Nummer) mit richtigen Namen(Buchstabennamen) zu versehen, möchte ich die aufgelisteten DateinamenNummern ablesen und die richtigen Dateien mit Namen versehen nach der Nummer 

Spich:

Zuvor: Aufgelistet 1234   --->  Danach   Aufgelistet 1234

          DateiName:1234                         DateiName:1234_Name

Ist es möglich bis zum Unterstrich_ nach der Nummer zu lesen?

Wenn jemand dazu beitragen kann, werde ich sehr dankbar sein!

Freundliche Grüße und Danke im Voraus!

Axl

Der Code:

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 = shZ.Cells(iRow, 2)
            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

Rest ist irrelevant...