Folge dem Video um zu sehen, wie unsere Website als Web-App auf dem Startbildschirm installiert werden kann.
Anmerkung: Diese Funktion ist in einigen Browsern möglicherweise nicht verfügbar.
regex.pattern = "^\d+\s+.+?\s+(\d+,\d{2})\s"
regex.global = true
regex.MultiLine = true
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
^\d+\s+.+?\s+(\d+,\d{2})\s[\s\S]+?Materialnummer:\s+(\d+)
'/**
' * 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
'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
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
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