txt-Datei mit Punkt bei Abk. und Sp.Trennung
26.01.2018 23:06:36
Matthias
ich möchte gern eine txt-Datei einlesen. Diese hat Punkte zur Spaltentrennung (nicht änderbar), Punkte bei diversen Abkürzungen und es kommen Zeilenumbrüche vor. Zur Verdeutlichung habe ich 2 txt-Dateien.
-https://www.herber.de/bbs/user/119312.txt, ausgelesene txt-Datei
-https://www.herber.de/bbs/user/119313.txt, diese txt-Datei
habe so bereinigt das die Zeilen und Spalten Zugehörigkeit zu ersehen ist
Die Liste wird auch in regelmäßigen Abständen aktualisiert werden müssen. Wobei sich in der Spalte Object keine Duplicate ergeben werden. Alle Objects die in der Spalte Release Status = Z9_freigegeben aufweisen werden sich nicht mehr ändern.
Bei allen andern Objects können sich Werte in den letzten 4 Spalten und in der Spalte Current Description ändern und müssen aktualisiert werden. Neue Objects sollen am Ende der Liste hinzugefügt werden.
Zum einlesen habe ich mir unten folgenden Code gebastelt und bin dann auf die beschriebenen Probleme gestoßen.
Über Eure Hilfe würde ich mich sehr freuen und wäre Euch sehr Dankbar.
Public Sub Daten_neu()
Dim datei1$
Dim lngZ As Long, Zeile1 As Long, nextZeile As Long
Dim SpObject As Long
Dim Spalte As Range
SpObject = 1
Zeile1 = 1
nextZeile = Zeile1 + 1
'file import ------------------------------------------------------------------------
Application.ScreenUpdating = False
datei1 = Application.GetOpenFilename("Textdateien (*.txt*), *.txt*")
If CStr(datei1) = CStr(False) Then
MsgBox "Sie haben keine Datei ausgewählt!", 48, "Keine Datei ausgewählt"
Exit Sub
End If
Workbooks.OpenText Filename:=datei1, DataType:=xlDelimited
Open "C:\Users\Public\zwsp.txt" For Output As #1
With ActiveSheet
Print #1, _
Join(WorksheetFunction.Transpose(.Range(.Cells(1, 1), _
.Cells(Rows.Count, 1).End(xlUp))), vbCrLf)
End With
Close #1
ActiveWorkbook.Close savechanges:=False
Open "C:\Users\Public\zwsp.txt" For Input As #1
Do While Not EOF(1)
Line Input #1, tmp
ActiveSheet.Cells(Zeile1, 3) = Replace(tmp, ". ", ".#")
Zeile1 = Zeile1 + 1
Loop
Close #1
'-------- Liste bereinigen ----------------------------------------------------------
'---------------------------- Leerzeichen entfernen ---------------------------------
On Error Resume Next
Dim Zelle As Range
For Each Zelle In ActiveSheet.UsedRange
Zelle.Value = WorksheetFunction.Trim(Zelle.Value)
Next Zelle
On Error GoTo 0
'---------------------------- Leerzeichen nach # entfernen --------------------------
On Error Resume Next
Dim SuchenNach As String
Dim ErsetzenDurch As String
SuchenNach = "# "
ErsetzenDurch = "#"
For Each Zelle In ActiveSheet.UsedRange
Zelle.Value = Application.Substitute(Zelle.Value, SuchenNach, ErsetzenDurch)
Next Zelle
On Error GoTo 0
'---------------------------- alle . entfernen --------------------------------------
SuchenNach = "."
ErsetzenDurch = ""
For Each Zelle In ActiveSheet.UsedRange
Zelle.Value = Application.Substitute(Zelle.Value, SuchenNach, ErsetzenDurch)
Next Zelle
On Error GoTo 0
'-------- split Tabelle -------------------------------------------------------------
For lngZ = 1 To Zeile1 + 1
txt = Split(Cells(lngZ, 3), "#")
For y = 0 To UBound(txt)
Cells(lngZ, y + SpObject) = txt(y)
Next
Next
Rows("1:5").Delete
Rows("1:1").AutoFilter
For Each Spalte In ActiveSheet.UsedRange.Columns
Spalte.AutoFit
Next Spalte
Range("A1").Activate
End Sub