Office: Bis zum bestimmten Wert auslesen

Helfe beim Thema Bis zum bestimmten Wert auslesen in Microsoft Excel Hilfe um das Problem gemeinsam zu lösen; Hallo Forumsmitglieder, ich möchte in mein Code(unten) folgendes einfügen: Werte aus der Spalte B "1234" (Dateinamen) mit den im gleichen... Dieses Thema im Forum "Microsoft Excel Hilfe" wurde erstellt von Bello, 3. Mai 2021.

  1. Bello Neuer User

    Bis zum bestimmten Wert auslesen


    Hallo Forumsmitglieder,

    ich möchte in mein Code(unten) folgendes einfügen:

    Werte aus der Spalte B "1234" (Dateinamen) mit den im gleichen Verzeichnis angelegten Mappen vergleichen. Diese Excelmappen heißen etwas anders als in der Spalte B.
    D.H. z.B. Spalte B Wert 1234...dazu finde mir die datei 1234_Logistik
    oder Wert X123443 dazu finde mir die Datei X123443_Transport

    Wäre es möglich sowas einzubaen, dass nur bis zum Unterstrich gelesen wird?

    P:S. mit Split() Methode hat bei mir nicht gefunkt, bzw. bin ich zu dumm...

    Freue mich sehr, wenn jemand ansatzweise was dazu beitragen kann!

    Freundliche Grüße
    Bel


    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
    
        Set WbZ = ThisWorkbook
        Set shZ = WbZ.Worksheets(1)  '<=== anpassen !!!! "1" Index 1 ist die erste Arbeitstabel
        Application.ScreenUpdating = False
        
        '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         'For iRow = 4 To shZ.Cells(WbZ.Rows.Count, 4).End(xlUp).Row
            'Überprüfen, ob in Spalte "Dateiname" 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)    'strDateiname = Split(shZ.Cells(iRow, 2),"_")(0)
                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")
                    
                      For I = 1 To Sheets.Count
                      ActiveWorkbook.Worksheets(I).Unprotect Password:="KKI"    'Schreibschutz aufheben
    
                    For j = 7 To 27
                       shZ.Cells(iRow, j) = objSheet.Cells(j + 19, 2)
                    Next j
                    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
    
    keineVerknuepfung
    Application.ScreenUpdating = True
    
    End Sub
    
     
    Bello, 3. Mai 2021
    #1
  2. Beverly
    Beverly Erfahrener User
    Hi,

    wenn ich das richtig verstanden habe, sind die Dateinamen in Spalte A sozusagen "unvollständig" und du willst prüfen, ob die betreffende Datei vorhanden ist? Benutze das Jokerzeichen "*"

    Code:
        If Dir(strPfad & shZ.Cells(iRow, 2) & "*.xlsm") <> "" Then
            MsgBox "Datei vorhanden"
        Else
            MsgBox "Datei nicht gefunden"
        End If
    

    Bis zum bestimmten Wert auslesen GrußformelBis zum bestimmten Wert auslesen Beverly's Excel - Inn
     
    Beverly, 3. Mai 2021
    #2
    1 Person gefällt das.
  3. Bello Neuer User
    Hallo Danke für die Rückmeldung,

    ist es auch möglich den Joker irgendwie in die Zeile

    Code:
     strDateipfad = strPfad & strDateiname & "*.xlsm" '
    einzufügen?
    Habs ausprobiert, kommt natürlich ein Fehler in der Funktion(hier nicht aufgeführt unten der Gesamtcode), mit Dateiname oder -nummer falsch...

    Ich möchte den Code nicht zu sehr verändern, da es seeeeeehr viel Zeit und Mühe gekostet hat, ihn zusammenzubasteln...
    und wenn ich Dir() benutze, werden die Werte nicht übertragen (lange Vorgeschichte)...daher die Len(Dir) Methode...


    Freundliche Grüße
    Bel

    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
    Application.ScreenUpdating = False
    
        Dim strDateipfad As String
        Dim strPfad As String
        Dim strDateiname As String
        Dim Wb As Workbook, WbZ As Workbook
    
        Set WbZ = ThisWorkbook
        Set shZ = WbZ.Worksheets(1)  '<=== anpassen !!!! "1" Index 1 ist die erste Arbeitstabelle
    
        '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" 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")
    
                      For I = 1 To Sheets.Count
                      ActiveWorkbook.Worksheets(I).Unprotect Password:="KKI"    'Schreibschutz aufheben
    
                    For j = 7 To 27
                       shZ.Cells(iRow, j) = objSheet.Cells(j + 19, 2)
                    Next j
                    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
    
    keineVerknuepfung
    Application.ScreenUpdating = True
    
    End Sub
    
    Sub keineVerknuepfung()
        Dim nRow As Long
        For nRow = 4 To Cells(Rows.Count, 4).End(xlUp).Row
            If Cells(nRow, 15).Value = "" Then
                Cells(nRow, 3) = "keine Verknüpfung"
            End If
        Next nRow
    End Sub
    
    Sub Abgleich1()  '<=== anpassen
    
    keineVerknuepfung
    Ubertragung        '<=== anpassen
    
    End Sub
    Function isFileOpen(sFullname As String) As Boolean
        Dim kn As Integer, errNum As Long
    
        On Error Resume Next                 '
        kn = FreeFile
        Open sFullname For Input Lock Read As #kn
            errNum = Err.Number              '
        Close #kn
        On Error GoTo 0                      '
    
        Select Case errNum
            Case 0          ' nicht geöffnet
                isFileOpen = False
    '       Case 70         ' bereits geöffnet                                            '
            Case 55, 70     ' bereits geöffnet(55), Zugriff/Berechtigung verweigert(70)   '
                isFileOpen = True
            Case Else       ' anderer Fehler
                Error errNum  'Fehler 52 Dateiname oder -nummer falsch
        End Select
    End Function
    
    'Code Message
    '----------------------------
    '52 Bad file name or number
    '53 File Not found
    '54 Bad file mode
    '55 File already open          <====
    '57 Device I/O error
    '58 File already exists
    '59 Bad record length
    '61 Disk Full
    '62 Input past end of file
    '63 Bad record number
    '67 Too many files
    '68 Device unavailable
    '70 Permission denied          <====
    '71 Disk Not Ready
    '74 Can 't rename with different drive
    '75 Path/File access error
    '76 Path Not found
     
    Bello, 4. Mai 2021
    #3
  4. Beverly
    Beverly Erfahrener User

    Bis zum bestimmten Wert auslesen

    Hi,

    dann liegt der Fehler in deiner hier nicht aufgeführten Funktion. Wenn ich meinen Code dahingehend ändere dass der Gesamtdateinamen einschließlich Pfad vorher zusammengesetzt wird, ergibt das nämlich keinen Laufzeitfehler:

    Code:
        strDateiname = shZ.Cells(iRow, 2)
        strDateipfad = strPfad & strDateiname & "*.xlsm"
        If Dir(strDateipfad) <> "" Then
            MsgBox "Datei vorhanden"
        Else
            MsgBox "Datei nicht gefunden"
        End If
    


    Bis zum bestimmten Wert auslesen GrußformelBis zum bestimmten Wert auslesen Beverly's Excel - Inn
     
    Beverly, 4. Mai 2021
    #4
    1 Person gefällt das.
  5. Bello Neuer User
    Ja,
    du hast völlig Recht, es stimmt was mit der Fnuktion nicht.

    Die untere Funktion funktionierte einwandfrei ohne den Joker. Warum wegen dem winzigen Zeichen ein Fehler auftritt, verstehe ich nicht Bis zum bestimmten Wert auslesen :(

    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
    Application.ScreenUpdating = False
    
        Dim strDateipfad As String
        Dim strPfad As String
        Dim strDateiname As String
        Dim Wb As Workbook, WbZ As Workbook
    
        Set WbZ = ThisWorkbook
        Set shZ = WbZ.Worksheets(1)  '<=== anpassen !!!! "1" Index 1 ist die erste Arbeitstabelle
    
        '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" 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")
    
                      For I = 1 To Sheets.Count
                      ActiveWorkbook.Worksheets(I).Unprotect Password:="KKI"    'Schreibschutz aufheben
    
                    For j = 7 To 27
                       shZ.Cells(iRow, j) = objSheet.Cells(j + 19, 2)
                    Next j
                    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
    
    keineVerknuepfung
    Application.ScreenUpdating = True
    
    End Sub
    
    Sub keineVerknuepfung()
        Dim nRow As Long
        For nRow = 4 To Cells(Rows.Count, 4).End(xlUp).Row
            If Cells(nRow, 15).Value = "" Then
                Cells(nRow, 3) = "keine Verknüpfung"
            End If
        Next nRow
    End Sub
    
    Sub Abgleich1()  '<=== anpassen
    
    keineVerknuepfung
    Ubertragung        '<=== anpassen
    
    End Sub
    Function isFileOpen(sFullname As String) As Boolean
        Dim kn As Integer, errNum As Long
    
        On Error Resume Next                 '
        kn = FreeFile
        Open sFullname For Input Lock Read As #kn
            errNum = Err.Number              '
        Close #kn
        On Error GoTo 0                      '
    
        Select Case errNum
            Case 0          ' nicht geöffnet
                isFileOpen = False
    '       Case 70         ' bereits geöffnet                                            '
            Case 55, 70     ' bereits geöffnet(55), Zugriff/Berechtigung verweigert(70)   '
                isFileOpen = True
            Case Else       ' anderer Fehler
                Error errNum  'Fehler 52 Dateiname oder -nummer falsch
        End Select
    End Function
    
    'Code Message
    '----------------------------
    '52 Bad file name or number
    '53 File Not found
    '54 Bad file mode
    '55 File already open          <====
    '57 Device I/O error
    '58 File already exists
    '59 Bad record length
    '61 Disk Full
    '62 Input past end of file
    '63 Bad record number
    '67 Too many files
    '68 Device unavailable
    '70 Permission denied          <====
    '71 Disk Not Ready
    '74 Can 't rename with different drive
    '75 Path/File access error
    '76 Path Not found
     
    Bello, 5. Mai 2021
    #5
  6. Exl121150 Erfahrener User
    Hallo,

    auch "winzige" Zeichen können große Auswirkungen haben.

    Es ist doch klar,. dass die "Dir(strDateiPfad)"-Funktion Jokerzeichen akzeptiert und sie somit einen gültigen, aktuellen Dateinamen (ohne Jokerzeichen) zurückliefert. Allerdings wird dieser zurückgelieferte Dateiname nur von der "Len(Retourdateiname)"-Funktion überprüft und dann nicht mehr verwendet. Die "Len(...)"-Funktion gibt eine Zahl >0 zurück, wenn in Retourdateiname ein Dateinamen zurückgegeben wurde (ohne Joker).

    Die im nächsten "IF" enthaltene "IsFileOpen(strDateiPfad)" duldet keine Jokerzeichen in "strDateiPfad", wie man feststellen kann, wenn man sie analysiert (Diese Funktion ist im Makro am Ende sehr wohl vorhanden!!). Da dieser (mit Joker versehene) Dateiname nicht existiert, liefert die Funktion weder "True" noch "False" zurück, sondern unterbricht die Ausführung mit einer Fehlermeldung wegen "Error errNum", wobei "errNum" den Wert 52 oder 53 enthalten wird (Bad file name or number / File not found).
     
    Exl121150, 5. Mai 2021
    #6
  7. Beverly
    Beverly Erfahrener User
    Du darfst strDateiname nicht direkt an die Funktion übergeben, da der Inhalt noch unbestimmt ist durch das Joker-Zeichen. Du musst stattdessen den tatsächlich gefundenen Dateinamen übergeben - also so:

    Code:
    If isFileOpen(Dir(strDateipfad)) Then


    Bis zum bestimmten Wert auslesen GrußformelBis zum bestimmten Wert auslesen Beverly's Excel - Inn
     
    Beverly, 5. Mai 2021
    #7
  8. Bello Neuer User

    Bis zum bestimmten Wert auslesen

    Hallo, Danke für die Rückmeldungen wirklich vom ganzen Herzen!

    habe die letzten Nachrichten berücksichtigt, und den Code von Beverly dazugefügt,
    leider kommt wieder ein Fehler, diesmal der 53 File Not Found, (obwohl der ExcelFile existiert) bei der Funktion.

    Im Debugfenster/bzw Lokalfenster sieht es bis zu dem Fehler alles wie gewünscht aus, außer dass das Programm die Werte gar nicht mehr überträgt.

    Kann hier geholfen werden?

    Freundliche Grüße
    Bel

    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
    Application.ScreenUpdating = False
    
        Dim strDateipfad As String
        Dim strPfad As String
        Dim strDateiname As String
        Dim Wb As Workbook, WbZ As Workbook
    
        Set WbZ = ThisWorkbook
        Set shZ = WbZ.Worksheets(1)  '<=== anpassen !!!! "1" Index 1 ist die erste Arbeitstabelle
    
        '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         'For iRow = 4 To shZ.Cells(WbZ.Rows.Count, 4).End(xlUp).Row
            'Überprüfen, ob in Spalte "Dateiname" 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 Dir(strDateipfad) <> "" Then
                    If isFileOpen(Dir(strDateipfad)) Then
                    shZ.Cells(iRow, 3) = "nicht aktuell"
                
                Cells(iRow, 3) = "aktuell"
    
                    Set Wb = Workbooks.Open(strDateipfad, ReadOnly:=True)
                    Set objSheet = Wb.Sheets("Schnittstelle")
    
                      For I = 1 To Sheets.Count
                      ActiveWorkbook.Worksheets(I).Unprotect Password:="KKI"    '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
    
    keineVerknuepfung
    Application.ScreenUpdating = True
    
    End Sub
    
    Sub keineVerknuepfung()
        Dim nRow As Long
        For nRow = 4 To Cells(Rows.Count, 4).End(xlUp).Row
            If Cells(nRow, 15).Value = "" Then
                Cells(nRow, 3) = "keine Verknüpfung"
            End If
        Next nRow
    End Sub
    
    Sub Abgleich1()  '<=== anpassen
    
    keineVerknuepfung
    Ubertragung        '<=== anpassen
    
    End Sub
    Function isFileOpen(sFullname As String) As Boolean
        Dim kn As Integer, errNum As Long
    
        On Error Resume Next                 '
        kn = FreeFile
        Open sFullname For Input Lock Read As #kn
            errNum = Err.Number              '
        Close #kn
        On Error GoTo 0                      '
    
        Select Case errNum
            Case 0          ' nicht geöffnet
                isFileOpen = False
    '       Case 70         ' bereits geöffnet                                            '
            Case 55, 70     ' bereits geöffnet(55), Zugriff/Berechtigung verweigert(70)   '
                isFileOpen = True
            Case Else       ' anderer Fehler
                Error errNum  'Fehler 53
        End Select
    End Function
    
    'Code Message
    '----------------------------
    '52 Bad file name or number
    '53 File Not found
    '54 Bad file mode
    '55 File already open          <====
    '57 Device I/O error
    '58 File already exists
    '59 Bad record length
    '61 Disk Full
    '62 Input past end of file
    '63 Bad record number
    '67 Too many files
    '68 Device unavailable
    '70 Permission denied          <====
    '71 Disk Not Ready
    '74 Can 't rename with different drive
    '75 Path/File access error
    '76 Path Not found
    
     
    Bello, 5. Mai 2021
    #8
  9. Beverly
    Beverly Erfahrener User
    Da mir deine Mappe nicht vorliegt, habe ich das jetzt mal nachgebaut und dabei den Code ordentlich eingerückt - er sicht jetzt so aus:

    Code:
        For iRow = 4 To Cells(Rows.Count, 4).End(xlUp).Row         'For iRow = 4 To shZ.Cells(WbZ.Rows.Count, 4).End(xlUp).Row
            'Überprüfen, ob in Spalte "Dateiname" 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 Dir(strDateipfad) <> "" Then
                    If isFileOpen(Dir(strDateipfad)) Then
                        shZ.Cells(iRow, 3) = "nicht aktuell"
                    Else
                        Cells(iRow, 3) = "aktuell"
                        Set Wb = Workbooks.Open(Dir(strDateipfad), ReadOnly:=True) '<== Code geändert!!!!
                        Set objSheet = Wb.Sheets("Schnittstelle")
                        For I = 1 To Sheets.Count
                            ActiveWorkbook.Worksheets(I).Unprotect Password:="KKI"    '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
    
    Außerdem habe ich noch eine Zeile geändert, und zwar für das Öffnen der Arbeitsmappe wenn diese vorhanden ist - siehe die Anmerkung im Code.

    Resultat: ich erhalte keinen Fehler und die Arbeitsmappe wird wie gewünscht geöffnet wenn sie vorhanden ist. Ist sie nicht vorhanden, läuft der Code weiter (ohne etwas zu machen), und das völlig fehlerfrei.



    Bis zum bestimmten Wert auslesen GrußformelBis zum bestimmten Wert auslesen Beverly's Excel - Inn
     
    Beverly, 5. Mai 2021
    #9
  10. Bello Neuer User
    Wau, Danke für die Mühe !!! vielmals!!!

    leider hat es bei mir die falschen Ergebnisse gebracht, da es keine Normalzahlen zu vergleichen sind, die ale gleich Lang sind und extrem unterschiedlich...
    Wenn ich das Programm ausführe findet er zwar die richtigen Dateien, dazu aber noch dataein die nicht existieren, z.B.
    Auflistung der zu lesenden Dateien:

    0711.X35401.003.04
    0711.X35401.003.04.01
    0711.X35401.003.04.02 <--- existiert nur diese
    0711.X35401.003.04.03

    Aufgrund, dass es die erste Datei 0711.X35401.003.04 ausliest und danach der Joker kommt, liest der Excel alle Dateien als ob sie existieren...so verstehe ich es
    Hatte die DateienBezeichnungen mit Namen versehen, die findet er kommischer Weise auch nicht, solche wie

    0711.X35401.003.04.02_Name
    0711.X35401.003.03_Name usw

    Wäre es möglich, dass umzugehen oder die Split() einzufügen ?

    Freudliche Grüße
    Bel

    Und ich hoffe sehr, dass ich nicht auf die Nerven gehe...

    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
    Application.ScreenUpdating = False
    
        Dim strDateipfad As String
        Dim strPfad As String
        Dim strDateiname As String
        Dim Wb As Workbook, WbZ As Workbook
    
        Set WbZ = ThisWorkbook
        Set shZ = WbZ.Worksheets(1)  '<=== anpassen !!!! "1" Index 1 ist die erste Arbeitstabelle
    
        '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         'For iRow = 4 To shZ.Cells(WbZ.Rows.Count, 4).End(xlUp).Row
            'Überprüfen, ob in Spalte "Dateiname" 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 Dir(strDateipfad) <> "" Then
                    If isFileOpen(Dir(strDateipfad)) Then
                        shZ.Cells(iRow, 3) = "nicht aktuell"
                    Else
                        Cells(iRow, 3) = "aktuell"
                        Set Wb = Workbooks.Open(Dir(strDateipfad), ReadOnly:=True) '<== Code geändert!!!!
                        Set objSheet = Wb.Sheets("Schnittstelle")
                        For I = 1 To Sheets.Count
                            ActiveWorkbook.Worksheets(I).Unprotect Password:="KKI"    '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
    
    keineVerknuepfung
    Application.ScreenUpdating = True
    
    End Sub
    
    Sub keineVerknuepfung()
        Dim nRow As Long
        For nRow = 4 To Cells(Rows.Count, 4).End(xlUp).Row
            If Cells(nRow, 15).Value = "" Then
                Cells(nRow, 3) = "keine Verknüpfung"
            End If
        Next nRow
    End Sub
    
    Sub Abgleich1()  '<=== anpassen
    
    keineVerknuepfung
    Ubertragung        '<=== anpassen
    
    End Sub
    Function isFileOpen(sFullname As String) As Boolean
        Dim kn As Integer, errNum As Long
    
        On Error Resume Next                 '
        kn = FreeFile
        Open sFullname For Input Lock Read As #kn
            errNum = Err.Number              '
        Close #kn
        On Error GoTo 0                      '
    
        Select Case errNum
            Case 0          ' nicht geöffnet
                isFileOpen = False
    '       Case 70         ' bereits geöffnet                                            '
            Case 55, 70     ' bereits geöffnet(55), Zugriff/Berechtigung verweigert(70)   '
                isFileOpen = True
            Case Else       ' anderer Fehler
    '            Error errNum
        End Select
    End Function
    
    'Code Message
    '----------------------------
    '52 Bad file name or number
    '53 File Not found
    '54 Bad file mode
    '55 File already open          <====
    '57 Device I/O error
    '58 File already exists
    '59 Bad record length
    '61 Disk Full
    '62 Input past end of file
    '63 Bad record number
    '67 Too many files
    '68 Device unavailable
    '70 Permission denied          <====
    '71 Disk Not Ready
    '74 Can 't rename with different drive
    '75 Path/File access error
    '76 Path Not found
     
    Bello, 6. Mai 2021
    #10
  11. Beverly
    Beverly Erfahrener User
    Und was steht in den Zellen?


    Bis zum bestimmten Wert auslesen GrußformelBis zum bestimmten Wert auslesen Beverly's Excel - Inn
     
    Beverly, 6. Mai 2021
    #11
    1 Person gefällt das.
  12. Bello Neuer User
    In den Zellen steht der Wert aus anderen Dateien:
    z. Beispiel

    0711.X35401.003.04 "Wert" von existierenden Datei
    0711.X35401.003.04.01
    0711.X35401.003.04.02 <--- existiert nur diese "Wert"
    0711.X35401.003.04.03

    Grüße
    Bel
     
    Bello, 6. Mai 2021
    #12
  13. Exl121150 Erfahrener User

    Bis zum bestimmten Wert auslesen

    Hallo,

    1) Ich habe eine Do-While-Loop-Schleife eingebaut, die alle Dateien eines Verzeichnisses sucht, die zum Joker-Dateinamen passsen.
    2) Ich habe den Rückgabetype der "isFileOpen(...)"-Funktion geändert (VbTriState): Nur wenn diese den Wert "vbFalse" zurückgibt, existiert die Datei und ist nicht bereits geöffnet.
    3) Ferner habe ich den tatsächlich existierenden (=ohne Joker) Dateinamen der Variablen "strDateipfad" zugewiesen.
    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
    
        '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         'For iRow = 4 To shZ.Cells(WbZ.Rows.Count, 4).End(xlUp).Row
            'Überprüfen, ob in Spalte "Dateiname" 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)
              
                strDateipfad = Dir(strDateipfad)
              
                Do While Len(strDateipfad)
                   If isFileOpen(strDateipfad) <> vbFalse Then
                        shZ.Cells(iRow, 3) = "nicht aktuell"
                   Else
                        Cells(iRow, 3) = "aktuell"
                        Set Wb = Workbooks.Open(strDateipfad, ReadOnly:=True) '<== Code geändert!!!!
                        Set objSheet = Wb.Sheets("Schnittstelle")
                        For I = 1 To Sheets.Count
                            ActiveWorkbook.Worksheets(I).Unprotect Password:="KKI"    '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
                  'Do-While-Loop-Schleife testet, ob noch weitere Dateien zum Joker-Dateinamen passen:
                  'Liefert Dir() einen ""-String zurück, gibt es keine weiteren Dateien
                   strDateipfad = Dir()
                Loop
              
            End If
    Nxt_File:
        Next iRow
        Set WbZ = Nothing: Set shZ = Nothing
    
        keineVerknuepfung
        Application.ScreenUpdating = True
    
    End Sub
    
    Sub keineVerknuepfung()
        Dim nRow As Long
        For nRow = 4 To Cells(Rows.Count, 4).End(xlUp).Row
            If Cells(nRow, 15).Value = "" Then
                Cells(nRow, 3) = "keine Verknüpfung"
            End If
        Next nRow
    End Sub
    
    Sub Abgleich1()  '<=== anpassen
    
        keineVerknuepfung
        Ubertragung        '<=== anpassen
    
    End Sub
    '
    'VbTriState-Typ: (vbUseDefault=-2 / vbTrue=-1(=True) / vbFalse=0(=False))
    '  bei Rückgabe von vbUseDefault: die Datei existiert nicht
    '  bei Rückgabe von vbTrue:       die Datei existiert und ist bereits geöffnet
    '  bei Rückgabe von vbFalse:      die Datei existiert und ist (noch) nicht geöffnet
    '
    Function isFileOpen(sFullname As String) As VbTriState '<== geänderter Rückgabetyp
        Dim kn As Integer, errNum As Long
    
        On Error Resume Next                 'Ausschalten der Error-Unterbrechung
        kn = FreeFile
        Open sFullname For Input Lock Read As #kn 'OPEN-Anweisung, um Öffnen der Datei zu testen:
            errNum = Err.Number                   'Ermitteln des Error-Status der OPEN-Anweisung
        Close #kn
        Err.Clear
        On Error GoTo 0                      'Einschalten der Error-Unterbrechung
    
        Select Case errNum
            Case 0          ' nicht geöffnet
                isFileOpen = vbFalse
            Case 55, 70     ' bereits geöffnet(55), Zugriff/Berechtigung verweigert(70)   '
                isFileOpen = vbTrue
            Case Else       ' anderer Fehler (zB. File not found(53))
                isFileOpen = vbUseDefault   '<== Weder TRUE noch FALSE !!
    '            Error errNum
        End Select
    End Function
    
    'Code Message
    '----------------------------
    '52 Bad file name or number
    '53 File Not found
    '54 Bad file mode
    '55 File already open          <====
    '57 Device I/O error
    '58 File already exists
    '59 Bad record length
    '61 Disk Full
    '62 Input past end of file
    '63 Bad record number
    '67 Too many files
    '68 Device unavailable
    '70 Permission denied          <====
    '71 Disk Not Ready
    '74 Can 't rename with different drive
    '75 Path/File access error
    '76 Path Not found
    
    
     
    Exl121150, 6. Mai 2021
    #13
    1 Person gefällt das.
  14. Bello Neuer User
    Hi,
    Danke erstmal für die Mühe,

    Das Programm macht bei mir folgendes:

    Es werden die Werte übertragen, es passt so, aber es werden die Werte in die Zellen für die nicht existierenden Dateien übertragen...so wie vorhin

    Dazu fehlt immer noch die Überprüfung der Dateien, sie verschwandt bzw. funktioniert nicht wie früher.
    D.h. zeigt den Status "aktuell" /"nicht aktuell" falsch an. Die Datei, die ich umbennene als z.B. von

    0711.X35401.003.04.02 auf -->
    0711.X35401.003.04.02_Name

    wird als geöffnete Datei angezeigt --> "nicht aktuell"

    Soweit zu dem,
    Danke für die Rückmeldungen!
    Freundliche Grüße
    Bel
     
    Bello, 6. Mai 2021
    #14
  15. Exl121150 Erfahrener User
    Hallo,

    ich habe jetzt auch das Innere des IF-Blockes "If isFileOpen(strDateipfad)=vbFalse Then" durchforstet und mit deinem ersten Posting in diesem Thread verglichen und entsprechend formuliert. Ferner habe ich das Ganze mit Kommentarzeilen versehen.
    Der VBA-Code ist jetzt so eingestellt, dass das 1. Arbeitsblatt der aktuellen Arbeitsmappe als Zielblatt für die Datenübertragung aus den gesuchten Dateien verwendet wird. Falls da etwas anderes stehen sollte, ist das in der entsprechend gekennzeichneten Zeile zu ändern. Jetzt steht dort:
    Set shZ = WbZ.Worksheets(1) 'oder WbZ.Activesheet '<=== anpassen !!!! "1" Index 1 ist das erste Arbeitsblatt
    Falls es das aktive Arbeitsblatt sein sollte, müsste dort stehen:
    Set shZ = WbZ.Activesheet
    Das gleiche gilt dann auch in der Sub Abgleich().

    Was mir aber bis jetzt nicht klar ist, ist der Umstand,
    1) dass du in der Zielmappe der Reihe nach den Blattschutz jedes Arbeitsblattes aufhebst und hinterher wieder einschaltest, obwohl du nur in einem einzigen Blatt der Zielmappe die Datentransponierung aus dem Quellblatt vornimmst.
    2) dass du auch nur aus dem einzigen Quellmappenblatt "Schnittstelle" diesen Datenübertrag machst (und zwar sooft als es Blätter in der Zielmappe gibt).
    Code:
    Option Explicit
    
    Sub Ubertragung()
    
        'Hilfsvariablen
        Dim iRow As Long, j As Long, I As Long
    
        Dim strDateipfad As String
        Dim strPfad As String
        Dim strDateiname As String
      
       'Arbeitsmappen-Objekte (Quelle,Ziel)
        Dim WbQ As Workbook, WbZ As Workbook
       'Arbeitsblatt-Objekte der jeweiligen Arbeitsmpappe (Excel-Datei)
        Dim shZ As Worksheet, shQ As Worksheet, shI As Worksheet
    
        Application.ScreenUpdating = False
        Set WbZ = ThisWorkbook
        Set shZ = WbZ.Worksheets(1)  'oder WbZ.Activesheet            '<=== anpassen !!!! "1" Index 1 ist das erste Arbeitsblatt
    
        'Pfad, in welchem die Dateien der zu
        'kopierenden Zellen sich befinden, auswählen
        strPfad = ThisWorkbook.Path & Application.PathSeparator
    
        For iRow = 4 To shZ.Cells(shZ.Rows.Count, 4).End(xlUp).Row    'Im 1. Zielmappen-Arbeitsblatt VON (Zeile 4) BIS (letzer Zelle mit Daten in Spalte D)
          
            If shZ.Cells(iRow, 2) = "" Then                           'Wenn Zelle in Spalte B leer, dann Exit
                Exit Sub
            Else
                strDateiname = shZ.Cells(iRow, 2)                     'Aus Spalte B den Dateinamen entnehmen
                strDateipfad = strPfad & strDateiname & "*.xlsm"      'zusammen mit Pfad und Joker und Dateierweiterung
            
                strDateipfad = Dir(strDateipfad)                      'Erster Dateiname, der zum vorherigen Joker-Dateinamen passt
            
                Do While Len(strDateipfad)                            'Falls es keinen passenden Dateinamen(="") mehr gibt: Schleife verlassen!!
              
                   If isFileOpen(strDateipfad) = vbFalse Then         'Passende Datei wurde aktuell als nicht geöffnet vorgefunden
                      shZ.Cells(iRow, 3) = "aktuell"
                      Set WbQ = Workbooks.Open(strDateipfad, ReadOnly:=True) 'Passende Datei als (Quell)datei öffnen
                      Set shQ = WbQ.Worksheets("Schnittstelle")              'Arbeitsblatt "Schnittstelle in Quelldatei ermitteln
                      For Each shI In WbZ.Worksheets                  'In (Ziel/akt.)Datei alle Arbeitsblätter durchlaufen
                          shI.Unprotect Password:="KKI"               'Schreibschutz des I.Zielblattes aufheben
                          For j = 7 To 27
                             shZ.Cells(iRow, j) = shQ.Cells(j + 19, 2)   'Schnittstelle!B26:B46 transponieren nach Zielblatt: Zeile iRow, Spalten G:AA
                          Next j
                          shI.Protect Password:="KKI"                 'Schreibschutz des I.Zielblattes einschalten
                      Next shI
                      WbQ.Close saveChanges:=False                    '(Quell)datei wieder ohne Änderung schließen
                   Else
                      shZ.Cells(iRow, 3) = "nicht aktuell"            'Passende Datei wurde aktuell geöffnet vorgefunden
                   End If
                  
                  'Do-While-Loop-Schleife testet, ob noch weitere Dateien zum Joker-Dateinamen passen:
                  'Liefert Dir() einen ""-String zurück, gibt es keine weiteren Dateien
                   strDateipfad = Dir()
                Loop
            
            End If
        Next iRow
    
        keineVerknuepfung shZ
        Application.ScreenUpdating = True
    
    End Sub
    
    Private Sub keineVerknuepfung(shBl As Worksheet)
        Dim nRow As Long
        With shBl
          For nRow = 4 To .Cells(.Rows.Count, 4).End(xlUp).Row
            If .Cells(nRow, 15).Value = "" Then
               .Cells(nRow, 3) = "keine Verknüpfung"
            End If
          Next nRow
        End With
    End Sub
    
    Sub Abgleich1()
    
        keineVerknuepfung ThisWorkbook.Worksheets(1)     'bzw: ThisWorkbook.ActiveSheet    '<=== Anpassen!!
        Ubertragung
    
    End Sub
    '
    'VbTriState-Typ: (vbUseDefault=-2 / vbTrue=-1(=True) / vbFalse=0(=False))
    '  bei Rückgabe von vbUseDefault: die Datei existiert nicht
    '  bei Rückgabe von vbTrue:       die Datei existiert und ist bereits geöffnet
    '  bei Rückgabe von vbFalse:      die Datei existiert und ist (noch) nicht geöffnet
    '
    Function isFileOpen(sFullname As String) As VbTriState '<== geänderter Rückgabetyp
        Dim kn As Integer, errNum As Long
    
        On Error Resume Next                      'Ausschalten der Error-Unterbrechung
        kn = FreeFile
        Open sFullname For Input Lock Read As #kn 'OPEN-Anweisung, um Öffnen der Datei zu testen:
            errNum = Err.Number                   'Ermitteln des Error-Status der OPEN-Anweisung
        Close #kn
        Err.Clear
        On Error GoTo 0                           'Einschalten der Error-Unterbrechung
    
        Select Case errNum
            Case 0          ' nicht geöffnet
                isFileOpen = vbFalse
            Case 55, 70     ' bereits geöffnet(55), Zugriff/Berechtigung verweigert(70)   '
                isFileOpen = vbTrue
            Case Else       ' anderer Fehler (zB. File not found(53))
                isFileOpen = vbUseDefault
        End Select
      
    End Function
    
    'Code Message
    '----------------------------
    '52 Bad file name or number
    '53 File Not found
    '54 Bad file mode
    '55 File already open          <====
    '57 Device I/O error
    '58 File already exists
    '59 Bad record length
    '61 Disk Full
    '62 Input past end of file
    '63 Bad record number
    '67 Too many files
    '68 Device unavailable
    '70 Permission denied          <====
    '71 Disk Not Ready
    '74 Can 't rename with different drive
    '75 Path/File access error
    '76 Path Not found
    
    
     
    Exl121150, 6. Mai 2021
    #15
Thema:

Bis zum bestimmten Wert auslesen

Die Seite wird geladen...
  1. Bis zum bestimmten Wert auslesen - Similar Threads - bestimmten Wert auslesen

  2. Wenn Wert in Spalte, dann kopiere bestimmte Zellen

    in Microsoft Excel Hilfe
    Wenn Wert in Spalte, dann kopiere bestimmte Zellen: Hallo zusammen Ich versuche einen Planer zu erstellen. Dazu müsste ich folgende Formel/ Makro erstellen, kann dies jedoch mit meinen Excelkünsten nicht: Falls der Wert in Spalte "A" "1" hat,...
  3. Bestimmte Werte anderes Tabellenblatt automatisch übertragen

    in Microsoft Excel Hilfe
    Bestimmte Werte anderes Tabellenblatt automatisch übertragen: Guten Tag, ich brauche Ihre Hilfe. Wir haben eine Tabelle "Klienten" als Datenbank, die sich nach und nach füllen wird. Z.B. zur Zeit gibt es nur 5 Klienten, deren Zahl wird im Laufe der Zeit auf...
  4. Prüfung ob Wert in Spalte mit Wert aus bestimmtem Bereich übereinstimmt

    in Microsoft Excel Hilfe
    Prüfung ob Wert in Spalte mit Wert aus bestimmtem Bereich übereinstimmt: Hallo zusammen, ich möchte, dass Excel prüft, ob der Text in Spalte H2 von Tabellenblatt 1 mit einem der Werte aus dem Bereich B2 bis B925 aus Tabellenblatt 2 übereinstimmt. Sofern dies der Fall...
  5. Letzten Wert eine Spalte auslesen und in eine bestimmte Zelle anzeigen

    in Microsoft Excel Hilfe
    Letzten Wert eine Spalte auslesen und in eine bestimmte Zelle anzeigen: Hallo MS-Office User! *winken Leider habe ich wieder ein kleines Problem. Ich habe eine Tabelle...dort möchte ich gerne immer den letzten Wert der Spalte "B" auslesen lassen und in einer anderen...
  6. Bestimmten Wert von rechts nach Links Auslesen

    in Microsoft Excel Hilfe
    Bestimmten Wert von rechts nach Links Auslesen: Hallo :), Ich versuche Daten aus einen Kopierten Text Auszulesen. Da dieser nicht auf Excel umzumandeln geht. Viele Daten konnte ich schon auslesen, bei einen Wert Scheitert es. Die...
  7. Bestimmte Werte aus Matrix auslesen und in Spalte schreiben

    in Microsoft Excel Hilfe
    Bestimmte Werte aus Matrix auslesen und in Spalte schreiben: Hallo zusammen, ich stehe vor einem Problem, das ich selbst nicht mehr lösen kann und zu dem ich bei einer schnellen Google Suche auch keine Antwort gefunden habe. Es geht um Folgendes: Ich...
  8. bestimmten Wert aus Tabelle auslesen

    in Microsoft Excel Hilfe
    bestimmten Wert aus Tabelle auslesen: Hallo, ich bin momentan total verzweifelt, da ich keine Formel hinbekomme, die so funktioniert, wie ich es will. Ich habe eine Umfrage gemacht und möchte gerne mit Excel die Auswertung machen....
  1. Diese Seite verwendet Cookies, um Inhalte zu personalisieren, diese deiner Erfahrung anzupassen und dich nach der Registrierung angemeldet zu halten.
    Auf dieser Website werden Cookies für die Zugriffsanalyse und Anzeigenmessung verwendet.
    Wenn du dich weiterhin auf dieser Seite aufhältst, akzeptierst du unseren Einsatz von Cookies.
    Information ausblenden