AW: Regläre Ausdrücke mit Condition
03.07.2017 09:18:06
fcs
Hallo Andre,
ich hab auf Basis deines Beispieltextes schon mal einen Versuch gestartet.
1. Kriterium ist die Anzahl der Punkte in einer Zeile, umggf. vieleZeilen schon Auszuschließen.
Danach wird der der Zeilentext am Punkt gesplittet und Teiltexte werden gemäß Vorgaben geprüft.
Erfüllt eine Zeile die Bedingungen dann wird sie in eine temporäre Textdatei geschhrieben.
Im Moment wird die Textdatei mit den Trefern zum Schluss in eine neue Arbeitsmappe ausgegeben per Datenimport. Zielblatt kann man aber ändern und als Parameter an das Importmakro übergeben.
Gruß
Franz
Sub prcImport_TextFile()
Dim varDatei, varTemp, strPfad As String
Dim strZeile As String, strLike As String
Dim FF1 As Integer, FF2 As Integer
Dim bolImport As Boolean
Dim varSplit As Variant, var12 As Variant, var34 As Variant, var5 As Variant
' On Error GoTo Fehler
varDatei = Application.GetOpenFilename(Filefilter:="Textdatei (*.txt),*.txt", _
Title:="Bitte Textdateimit den Importdaten auswählen", _
ButtonText:="Auswählen")
If varDatei = False Then Exit Sub
FF1 = FreeFile()
Open varDatei For Input As #FF1
'temporäre Textdatei für Trefferzeilen öffnen
varTemp = ThisWorkbook.Path & Application.PathSeparator & "tempImport.txt"
FF2 = FreeFile()
Open varTemp For Output As #FF2
strLike = "[a-zA-Z0-9_]" 'zulässige Zeichen in Teiltexten
Do Until EOF(FF1)
Input #FF1, strZeile
bolImport = False
'Textanalyse
If Trim(strZeile) = "" Then
'Leere Zeile
Else
'Inputzeile am "."splitten
varSplit = VBA.Split(strZeile, ".")
Select Case UBound(varSplit) 'entspricht der Anzahl Punkte in der Zeile
Case 0
'keine Punkte im Zeilentext
Case 1
If UBound(varSplit) = 1 Then
If Trim(varSplit(0)) "" And fncLike(varSplit(0), strLike) Then
If Trim(varSplit(1)) "" And fncLike(varSplit(1), strLike) Then
'1. Zeile einer Serie
var12 = varSplit(0)
var34 = varSplit(1) & "[0]"
var5 = ""
bolImport = True
End If
End If
End If
Case 2
If varSplit(0) = var12 Then
If varSplit(1) = var34 Then
'prüfen ob 1. Zeile mit Zusatzrtext (ohne [#] am Ende)
If Trim(varSplit(2)) "" And fncLike(varSplit(2), strLike) Then
var5 = varSplit(2)
bolImport = True
'prüfen ob weitere Zeilen mit Zusatztext [#] am Ende
ElseIf varSplit(2) Like var5 & "[[]#]" Then
bolImport = True
End If
End If
End If
Case Else
'mehr als 2 Punkte im Zeilentext
End Select
End If
If bolImport = True Then
Print #FF2, strZeile
End If
Loop
Close FF1
Close FF2
Call prcText_Import(strFile:=varTemp, strStartzelle:="A2", strOtherDilimiter:=".")
VBA.Kill Pathname:=varTemp
Fehler:
With Err
Select Case .Number
Case 0 'Alles OK
Case Else
MsgBox "Fehler-Nr.: " & .Number & vbLf & .Description
Close
End Select
End With
End Sub
Public Function fncLike(ByVal strText As String, ByVal strLike As String) As Boolean
'Vergleich aller Zeichen in einem Text mit einem Muster Text
Dim intPos As Integer
fncLike = True
For intPos = 1 To Len(strText)
If Not Mid(strText, intPos, 1) Like strLike Then
fncLike = False
Exit For
End If
Next
End Function
Sub prcText_Import(ByVal strFile As String, _
Optional wksZiel As Worksheet, _
Optional strStartzelle As String = "A1", _
Optional strOtherDilimiter As String = "")
' Text_Import Makro
Dim wkbZiel As Workbook
Dim objQT As QueryTable
If wksZiel Is Nothing Then
Application.Workbooks.Add Template:=xlWBATWorksheet
Set wksZiel = ActiveWorkbook.Worksheets(1)
End If
Set wkbZiel = wksZiel.Parent
wksZiel.UsedRange.Clear
With wksZiel.QueryTables.Add(Connection:= _
"TEXT;" & strFile, Destination:=wksZiel.Range(strStartzelle))
.Name = "tempImport"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = False
.AdjustColumnWidth = True
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = 1252 'Windows Westeuropa
.TextFileStartRow = 1
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = False
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = False
.TextFileSpaceDelimiter = False
.TextFileOtherDelimiter = strOtherDilimiter
.TextFileColumnDataTypes = Array(1, 1, 1)
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With
Set objQT = wksZiel.QueryTables(1)
With objQT
wkbZiel.Connections("tempImport").Delete
.Delete
End With
End Sub