Maschinendaten in Datenbank konvertieren

[Fennek]

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

[Papierkrieger]

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

[Fennek]

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

[schauan]

Hallöchen,

Frage A2, z.B.:

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

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.

[Fennek]

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

[Fennek]

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.