Clever-Excel-Forum

Seiten: 1 2

Hallo,

so ist es etwas einfacher:

Code:
Const Pfad As String = "c:\users\xxxxxxxx\desktop\" '<<< anpassen

Sub F_en_V2()

Dim WBQ As Workbook

Dim WQ As Worksheet

Dim WZ As Worksheet

Dim RNG As Range, SP1 As Range, SP2 As Range

Set WZ = Sheets(2)                     '<<<< prüfen (Sheet2 der Beispieldatei)

lr = WZ.Cells(Rows.Count, 1).End(xlUp).Row

f = Dir(Pfad & "*.xlsx")   ' "Papiertige*.xlsx")

Do While Len(f)

    Set WBQ = Workbooks.Open(Pfad & f)

    Set WQ = WBQ.Sheets(1)

    With WQ.Columns(1)

        .UnMerge

        Set RNG = .Find("Teile-Nr:", , xlValues, xlWhole)

        If Not RNG Is Nothing Then

            Adr = RNG.Address

            Do

               lr = lr + 1

               WZ.Cells(lr, 1) = .Cells(19, 1)

               Set SP1 = RNG.End(xlToRight)

                    SP1.Resize(8).Copy

                    WZ.Cells(lr, 2).PasteSpecial Transpose:=True

               Set SP2 = SP1.End(xlToRight).End(xlToRight)

                    SP2.Resize(5).Copy

                    WZ.Cells(lr, "j").PasteSpecial Transpose:=True

            Set RNG = .FindNext(RNG)

            Loop Until RNG.Address = Adr

        End If

    End With

    WBQ.Close 0

f = Dir

Loop

End Sub

Die Aussage über die Begrenzheit von Forenhilfe bleibt.

mfg

(13.02.2020, 11:40)Fennek schrieb: [ -> ]Hallo,

so ist es etwas einfacher:

Code:
...

Die Aussage über die Begrenzheit von Forenhilfe bleibt.

mfg

Hallo Fenneck,
Jetzt bin ich mal wieder dazu gekommen. Ich habe den Code an meinen Fall angepasst und bin fast vollständig fertig. Es klappt soweit wie es momentan soll. Vielen Dank!
Um den Vorgang nun noch etwas zu automatisieren / schneller zu gestalten würde ich den Code gerne beliebig oft (gemäß der Anzahl der Dateien in meinem "noch einzupflegen" - Verzeichnis) wiederholen und

f = Dir(Pfad & "*.xlsx")

entsprechend automatisch anpassen. Gibt es da Mittel und Wege? Ich denke mir ja, dass für jede Datei in meinem Verzeichnis eine Variable erstellt werden müsste, die er als Zieldatei ansprechen muss um den Code für jede Datei und somit jede Variable zu wiederholen?

Oder ich erstelle eine Eingabespalte mit bspw. 10 Zeilen für Dateinamen, in denen man die Namen der jeweiligen Zieldateien manuell reinkopiert. Neben diese 10 Zeilen lege ich dann je eine Schaltfläche, die zu dem entsprechenden Code - angepasst auf die danebenliegende Quellzelle - passt, um für 10 zu verarbeitende Maschinenprotokolle 10 mal zu klicken.

Machbar oder nicht?

Ich habe schon etwas versucht, aber bin überfragt, wie ich den Zellinhalt von beispielsweise A2 als Teil von f = Dir(Pfad & "*.xlsx") in die Formel bastel, damit er auch die entsprechende Datei anspricht.

Gruß Papierkrieger

Hallo,

so wie der Code jetzt ist, werden bei jedem Start ALLE Dateien des Ordners bearbeitet. Um NUR neue Datei einzulesen ist eine kleine Ergänzung notwendig:

NACH dem Einlesen ein Markierung der Datei:

SetAttr Pfad & f, readonly

und VOR der Schleife ein

GetAttr Pfad & f

Sofern das "Readonly" ist wird die Verarbeitung dieser Datei übersprungen.

Ich hoffe, dass das Deine Frage beantwortet.

mfg

Hallöchen,

Frage A2, z.B.:

f = Dir(Pfad & Range("A2").Value & ".xlsx")

Zitat:und VOR der Schleife ein
GetAttr Pfad & f

Das hätte dann zur Konsequenz, dass es nur bei der ersten Datei was bringt. Und um was zu bewirken, musst Du sicher auch noch eine Bedingung programmieren.

@Andre:

man muss die Befehle und die If-Abfrage schon richtig positionieren.

Aber das soll der Fragesteller einmal versuchen, nur im Notfall, wenn es gar nicht gehen sollte, fahre ich meinen PC deswegen noch einmal hoch.

so hatte ich es mir vorgestellt:

Code:
Const Pfad As String = "c:\users\xxxxx\desktop\" '<<< anpassen

Sub F_en_V2()

Dim WBQ As Workbook

Dim WQ As Worksheet

Dim WZ As Worksheet

Dim rng As Range, SP1 As Range, SP2 As Range

Set WZ = Sheets(2)                     '<<<< prüfen (Sheet2 der Beispieldatei)

lr = WZ.Cells(Rows.Count, 1).End(xlUp).Row

f = Dir(Pfad & "Papiertige*.xlsx")

Do While Len(f)

    If GetAttr(Pfad & f) <> vbReadOnly Then

        Set WBQ = Workbooks.Open(Pfad & f)

        Set WQ = WBQ.Sheets(1)

        With WQ.Columns(1)

            .UnMerge

            Set rng = .Find("Teile-Nr:", , xlValues, xlWhole)

            If Not rng Is Nothing Then

                Adr = rng.Address

                Do

                   lr = lr + 1

                   WZ.Cells(lr, 1) = .Cells(19, 1)

                   Set SP1 = rng.End(xlToRight)

                        SP1.Resize(8).Copy

                        WZ.Cells(lr, 2).PasteSpecial Transpose:=True

                   Set SP2 = SP1.End(xlToRight).End(xlToRight)

                        SP2.Resize(5).Copy

                        WZ.Cells(lr, "j").PasteSpecial Transpose:=True

                Set rng = .FindNext(rng)

                Loop Until rng.Address = Adr

            End If

        End With

        WBQ.Close 0

        SetAttr Pfad & f, vbReadOnly

    End If

f = Dir

Loop

End Sub

Zum Testen kann die "If GetAttr" auskommentiert werden, oder mit "SetAttr Pfad & f, vbNormal" zurückgesetzt werden.

Seiten: 1 2

Fennek

Papierkrieger

Fennek

schauan

Fennek

Fennek