Office: 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

 

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

---

 

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

 

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

---

 

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

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

 

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).

 

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

---

 

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

 

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.

---

 

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

 

Und was steht in den Zellen?

---

 

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

 

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

 

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

 

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