RegEx bestimmten Wert auslesen

bustue

Grünschnabel
Hallo Yaslaw,
anbei mal das Testfile, die Seiten können auf Grund der Positionen variieren.
 

Anhänge

  • Bestellnr.txt
    8,8 KB · Aufrufe: 3

Yaslaw

n/a
Moderator
https://regex101.com/r/VPbNMi/2
Code:
regex.pattern = "^\d+\s+.+?\s+(\d+,\d{2})\s"
regex.global = true
regex.MultiLine = true

Es sucht jetzt nach
Zeilenanfang -> Zahlen -> Belibiege Zeichen -> (Mindestens 1 Ziffer->Komma->2 Ziffern)

Die Frage dabei. wie ist es formatiert, wenn es mehr als 1000 Stück sind?
 

bustue

Grünschnabel
Hallo Yaslaw, Du bist toll.
kannst Du mir vielleicht behilflich sein siehe Testfile, wie bekomme ich die drei Materialnummern mit Menge in Spalte A und B eines Arbeitsblattes.
hiermit liest er nur die erste Pos aus:
Visual Basic:
For Each file In objSFold.Files                                  ' wieder alles einlesen
        If Right(file.Path, 4) = ".txt" Then colTFiles.Add file.Path  ' nur *.txt
    Next
  
    Set objWks = Worksheets(1)
    Set rngLastRow = objWks.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
  
    For i = 1 To colTFiles.Count
        strTXT = FSO.OpenTextFile(colTFiles.Item(i)).ReadAll
      
        'Ártikelnr auslesen
        regex.Pattern = "Materialnummer: ([^\r\n]+)"
        Set matches = regex.Execute(strTXT)
        If matches.Count > 0 Then
            rngLastRow.Cells(1, 1).Value = matches(0).SubMatches(0) 'Artikelnr in Spalte A speichern
        End If
              
        'Menge auslesen
        regex.Pattern = "^\d+\s+.+?\s+(\d+,\d{2})\s"
        Set matches = regex.Execute(strTXT)
        If matches.Count > 0 Then
            rngLastRow.Cells(1, 2).Value = matches(0).SubMatches(0) 'Menge in Spalte B speichern
        End If
            
      
      
        Set rngLastRow = rngLastRow.Offset(1, 0)
      
    Next
    Set FSO = Nothing
    Set regex = Nothing
    Set WSHShell = Nothing
    Set objSFold = Nothing
End Sub
Wäre top wenn Du helfen könntest.
 
Zuletzt bearbeitet von einem Moderator:

Yaslaw

n/a
Moderator
item: RegExp vor der Schlaufr definieren und den Pattern nur einmal setzen. Ist schneller

item: Wenn jede Materialnummer nur eine Zeile hat, dann kannst du locker alles mit einem regExp erschlagen und hast immer die richtige Kombination
https://regex101.com/r/VPbNMi/3
Code:
^\d+\s+.+?\s+(\d+,\d{2})\s[\s\S]+?Materialnummer:\s+(\d+)

item: die letzte Zeile solltest du mit einer eigenen Funktion ermitteln. Damit Leerzeilen ignoriert werden
Visual Basic:
'/**
' * Ermittelt die letzte gefüllte Zeile eines Worksheets
' * @param  Worksheet oder Range   Das Objekt, das durchsucht werden soll
' * @return Long        Die Zeilennummer. Wenn das ganze Sheet leer ist, ist der Rückgabewert 0
' */
Public Function xlsGetLastRow(ByRef sheet As Object) As Long
    Const xlCellTypeLastCell = 11

    'Zur letzten initialisierten Zeile gehen
    xlsGetLastRow = sheet.cells.SpecialCells(xlCellTypeLastCell).row
    
    'Von dort zurücksuchen bis zur Letzten zeile mit Inhalt
    Do While sheet.Application.WorksheetFunction.CountA(sheet.rowS(xlsGetLastRow)) = 0 And xlsGetLastRow > 1
        xlsGetLastRow = xlsGetLastRow - 1
    Loop
End Function

Im Endeffekt würde ich es etwa so lösen
Visual Basic:
    'RegExp erstellen
    Dim regex As Object
    Dim matches As Object
    Dim match As Object
    Dim strFlPath As Object 
    Dim i

    Set regex = CreateObject("VBScript.RegExp")
    regex.Pattern = "^\d+\s+.+?\s+(\d+,\d{2})\s[\s\S]+?Materialnummer:\s+(\d+)"
    regex.Global = true
    regex.MultiLine = true

    For Each file In objSFold.Files                                  ' wieder alles einlesen
        If fso.GetExtensionName(file.Path) = "txt" Then colTFiles.Add file.Path  ' nur *.txt
    Next

    Set objWks = Worksheets(1)
    lngLastRow = xlsGetLastRow(objWks)

    For Each strFlPath in colTFiles
        strTXT = FSO.OpenTextFile(strFlPath).ReadAll
        If regex.test(strTXT) Then
            Set matches = regex.Execute(strTXT)
            For Each match in matches
                i = i + 1
                'MeterialNummer
                objWks.Cells(i + lngLastRow, 1).Value = match.SubMatches(1)
                'Menge
                objWks.Cells(i + lngLastRow, 2).Value = match.SubMatches(0)
            next match
        End If
    Next
 

bustue

Grünschnabel
Hallo Yaslaw, recht vielen Dank für Deine Mühe, aber ich bin wohl zu dumm um es hinzubekommen:
mein Code sieht jetzt so aus:
Code:
   Sub PDF2Excel()
   
    Dim strCMDLine As String, strTXT As String
    Dim FSO As Object, objSFold As Object, objWks As Object, WSHShell As Object, file As Object, rngLastRow As Range
    Dim colPFiles As New Collection, colTFiles As New Collection
   
    Set WSHShell = CreateObject("WScript.Shell")
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set regex = CreateObject("vbscript.regexp")
    regex.MultiLine = True
    Set objSFold = FSO.GetFolder(ThisWorkbook.Path)
   
    strCMDLine = """" & ThisWorkbook.Path & "\pdftotext.exe"" -raw -layout -nopgbrk "
       
    For Each file In objSFold.Files                                  ' alle Dateien einlesen
        If Right(file.Path, 4) = ".pdf" Then colPFiles.Add file.Path  ' nur *.pdf
    Next
   
    For i = 1 To colPFiles.Count
         WSHShell.Run strCMDLine & """" & colPFiles.Item(i) & """", 0, True
    Next
        
  'RegExp erstellen
    Dim regex As Object
    Dim matches As Object
    Dim match As Object
    Dim strFlPath As Object
    Dim i

    Set regex = CreateObject("VBScript.RegExp")
    regex.Pattern = "^\d+\s+.+?\s+(\d+,\d{2})\s[\s\S]+?Materialnummer:\s+(\d+)"
    regex.Global = True
    regex.MultiLine = True

    For Each file In objSFold.Files                                  ' wieder alles einlesen
       If FSO.GetExtensionName(file.Path) = "txt" Then colTFiles.Add file.Path  ' nur *.txt
   Next

    Set objWks = Worksheets(1)
    lngLastRow = xlsGetLastRow(objWks)

    For Each strFlPath In colTFiles
        strTXT = FSO.OpenTextFile(strFlPath).ReadAll
        If regex.test(strTXT) Then
            Set matches = regex.Execute(strTXT)
            For Each match In matches
                i = i + 1
                'Materialnummer
               objWks.Cells(i + lngLastRow, 1).Value = match.SubMatches(1)
                'Menge
               objWks.Cells(i + lngLastRow, 2).Value = match.SubMatches(0)
            Next match
        End If
    Next
   
End Sub
'/**
' * Ermittelt die letzte gefüllte Zeile eines Worksheets
' * @param  Worksheet oder Range   Das Objekt, das durchsucht werden soll
' * @return Long        Die Zeilennummer. Wenn das ganze Sheet leer ist, ist der Rückgabewert 0
' */
Public Function xlsGetLastRow(ByRef sheet As Object) As Long
    Const xlCellTypeLastCell = 11

    'Zur letzten initialisierten Zeile gehen
   xlsGetLastRow = sheet.Cells.SpecialCells(xlCellTypeLastCell).Row
   
    'Von dort zurücksuchen bis zur Letzten zeile mit Inhalt
   Do While sheet.Application.WorksheetFunction.CountA(sheet.Rows(xlsGetLastRow)) = 0 And xlsGetLastRow > 1
        xlsGetLastRow = xlsGetLastRow - 1
    Loop
End Function
Irgendwas mache ich gewaltig falsch. :-(
Ich bin hinsichtlich VBA auch keine besondere Leuchte.
 

Yaslaw

n/a
Moderator
Fehlverhalten?
Fehlermeldung?
Was läuft falsch?

Grundsätzlich hast du regex 2 mal deklariert und 2 mal erstellt.
Für mein Beispiel hatte ich den Anfang deiner Sub nicht zur Verfügung und wusste nicht, was schon deklariert war.
 

bustue

Grünschnabel
Man Du hast wirklich Ausdauer, heißen Dank.
Das Script läuft zunächst bei
Code:
 Dim regex As Object
als Mehrfachdekleration im aktuellen Gültigkeitsbereich auf.
Dito für
Code:
Dim i.
Beides auskommentiert, dann Debug auf
Code:
For Each strFlPath In colTFiles
 

Yaslaw

n/a
Moderator
Ich kann den Fehler grad nicht erklären. ev müsste strFlPath als Variant definiert sein.

Aber dein Code ist unnütz aufgeblasen.
Dateien auslesen und in eine Collection schreiben. Nächster Schritt, die Collection durchiterieren und damit was machen. Wozu die Collection dazwischen?

Mein Vorschlag:
Visual Basic:
Sub PDF2Excel()
    Dim strCMDLine As String, strTXT As String
    Dim FSO As Object, objSFold As Object, objWks As Object, WSHShell As Object, file As Object
    Dim regex As Object, matches As Object, match As Object
    Dim rowNr As Long

    Set WSHShell = CreateObject("WScript.Shell")
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set objSFold = FSO.GetFolder(ThisWorkbook.Path)

    'PDF to TXT
    strCMDLine = """" & ThisWorkbook.Path & "\pdftotext.exe"" -raw -layout -nopgbrk "

    For Each file In objSFold.Files                                  ' alle Dateien einlesen
        If FSO.GetExtensionName(file.Path) = "pdf" Then
            WSHShell.Run strCMDLine & """" & file.Path & """", 0, True
        End If
    Next

    'TXT to Excel
    Set regex = CreateObject("VBScript.RegExp")
    regex.Pattern = "^\d+\s+.+?\s+(\d+,\d{2})\s[\s\S]+?Materialnummer:\s+(\d+)"
    regex.Global = True
    regex.MultiLine = True

    Set objWks = Worksheets(1)
    'letzte Zeile
    rowNr = xlsGetLastRow(objWks)

    For Each file In objSFold.Files                                  ' wieder alles einlesen
        If FSO.GetExtensionName(file.Path) = "txt" Then
            strTXT = FSO.OpenTextFile(file.Path).ReadAll
            If regex.test(strTXT) Then
                Set matches = regex.Execute(strTXT)
                For Each match In matches
                    'Nächste Zeile'
                    rowNr = rowNr + 1
                    'Materialnummer
                    objWks.Cells(rowNr, 1).Value = match.SubMatches(1)
                    'Menge
                    objWks.Cells(rowNr, 2).Value = match.SubMatches(0)
                Next match
            End If
        End If
    Next
End Sub


'/**
' * Ermittelt die letzte gefüllte Zeile eines Worksheets
' * @param  Worksheet oder Range   Das Objekt, das durchsucht werden soll
' * @return Long        Die Zeilennummer. Wenn das ganze Sheet leer ist, ist der Rückgabewert 0
' */
Public Function xlsGetLastRow(ByRef sheet As Object) As Long
    Const xlCellTypeLastCell = 11

    'Zur letzten initialisierten Zeile gehen
    xlsGetLastRow = sheet.Cells.SpecialCells(xlCellTypeLastCell).Row

    'Von dort zurücksuchen bis zur Letzten zeile mit Inhalt
    Do While sheet.Application.WorksheetFunction.CountA(sheet.Rows(xlsGetLastRow)) = 0 And xlsGetLastRow > 1
        xlsGetLastRow = xlsGetLastRow - 1
    Loop
End Function