TXT-Datei zeilenweise verarbeiten

Hallo,
kann mir bitte jemand bei dem folgenden Problem helfen?
Ich habe eine TXT-Datei, die zeilenweise beschrieben wird. In jeder Zeile stehen Informationen durch ";" getrennt
Wert1;Wert2;Wert3;Wert4
Es geht um das schnelle Erstellen einer Excel-Tabelle pro Person, an welchen Aufträgen die Person jeweils gearbeitet hat. Das Auslesen der Datei erfolgt mehrfach. In der TXT-Datei stehen mehr als 1000 Zeilen.
Die Inhalte aus der TXT-Datei sollen nun in eine Excel-Datei umgeschrieben werden. Und genau an dieser Stelle fehlt mir der richtige Ansatz und das VBA-Wissen, denn folgendes soll gemacht werden:
1.) Für jeden Namen soll eine eigenen Tabelle angelegt werden und in diese soll dann fortlaufend geschrieben werden
2.) der Wert1 soll auf doppelte überprüft werden
3.) gibt es den Wert1 mehrfach soll Wert2 auf doppelte überprüft werden
4.) ist Wert1 und Wert2 gleich und auch mehrfach vorhanden, dann soll jeweils der Wert3 der Größe nach in die gleiche Zeile in hintereinander liegende Zellen geschrieben werden
5.) ansonsten soll in die nächste Zeile in der Excel-Tabelle geschrieben werden
6.) die Zeilen, die ausgelesen wurde, soll dann aus der TXT-Datei gelöscht werden
7.) Die TXT-Datei füllt sich immer wieder
Vielen Dank für eure Hilfe.
Gruß Michael
z.B. Inhalt der TXT-Datei
Peter Müller;12.01.2022;Auftrag 13;adrwersdf
Peter Müller;12.01.2022;Auftrag 15;adrwersdf
Hans Müller;12.01.2022;Auftrag 14;sadfwersdf
Hans Müller;12.01.2022;Auftrag 16;sadfwersdf
Peter Müller;12.01.2022;Auftrag 17;adrwersdf
Peter Huber;15.01.2022;Auftrag 20;adsfwer
Peter Huber;15.01.2022;Auftrag 21;adsfwer
Daniel Peter;18.01.2022;Auftrag 22;adsfwersydf
Daniel Peter;18.01.2022;Auftrag 23;adsfwersydf
Daniel Peter;18.01.2022;Auftrag 26;adsfwersydf
Daniel Peter;18.01.2022;Auftrag 28;adsfwersydf
Peter Müller;12.01.2022;Auftrag 18;adrwersdf
Ergebnis in der Excel-Datei sollte dann so aussehen:
A1: Peter Müller
B1: 12.01.2022
C1: Auftrag 13
D1: Auftrag 15
E1: Auftrag 17
F1: Auftrag 18
A2: Hans Müller
B2: 12.01.2022
C2: Auftrag 14
D2: Auftrag 16
E2:
F2:
A3: Peter Huber
B3: 15.01.2022
C3: Auftrag 20
D3: Auftrag 21
E3:
F3:
A4: Daniel Peter
B4: 18.01.2022
C4: Auftrag 22
D4: Auftrag 23
E4: Auftrag 26
F4: Auftrag 28
usw.

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub TXT_einlesen() Dim TxtDat As String, LR As Long, LC As Integer, Zeile As Long Dim TText As String, Arr, Trenn As String TxtDat = "E:\excel\Temp\Test.txt" Trenn = ";" Application.ScreenUpdating = False If Dir(TxtDat) = "" Then MsgBox TxtDat & vbLf & vbLf & "Nicht gefunden" Exit Sub End If With ActiveSheet 'Reset Close #1 .Cells.ClearContents 'Einlesen Open TxtDat For Input As #1 Do While Not EOF(1) Line Input #1, TText 'Trennen Arr = Split(TText, Trenn) 'Kombination von Name|Datum schon vorhanden? If WorksheetFunction.CountIf(.Columns(1), Arr(0) & "|" & Arr(1)) = 0 Then 'neu anlegen LR = .Cells(.Rows.Count, "A").End(xlUp).Row 'letzte Zeile der Spalte .Cells(LR + 1, 1) = Arr(0) & "|" & Arr(1) .Cells(LR + 1, 2) = Arr(2) Else 'in welcher Zeile vorhanden Zeile = Application.Match(Arr(0) & "|" & Arr(1), .Columns(1), 0) LC = .Cells(Zeile, .Columns.Count).End(xlToLeft).Column ' letzte Spalte .Cells(Zeile, LC + 1) = Arr(2) End If Loop Close #1 'Erste Spalte trennen .Columns(2).Insert Shift:=xlToRight .Columns(1).TextToColumns Destination:=.Columns(1), DataType:=xlDelimited, Other:=True, _ OtherChar:="|", FieldInfo:=Array(Array(1, 1), Array(2, 4)) End With 'Datei löschen Kill TxtDat Application.ScreenUpdating = True End Sub

Option Explicit Public Sub Read_TXT() Const TXT_PATH As String = "H:\221007\Test.txt" ' Pfad anpassen !!! Const FOR_READING As Long = 1, FOR_WRITING As Long = 2 Const TRISTATE_USEDEFAULT As Long = -2 Dim objFileSystemObject As Object, objFile As Object, objTextStream As Object Dim objWorksheet As Worksheet Dim strText As String, astrRows() As String, astrItems() As String Dim ialngRow As Long Dim blnNewWorksheet As Boolean If FileLen(TXT_PATH) > 0 Then Set objFileSystemObject = CreateObject(Class:="Scripting.FileSystemObject") Set objFile = objFileSystemObject.GetFile(TXT_PATH) Set objTextStream = objFile.OpenAsTextStream(FOR_READING, TRISTATE_USEDEFAULT) strText = objTextStream.ReadAll Call objTextStream.Close Set objTextStream = objFile.OpenAsTextStream(FOR_WRITING, TRISTATE_USEDEFAULT) Call objTextStream.Write(vbNullString) Call objTextStream.Close Set objFileSystemObject = Nothing Set objFile = Nothing Set objTextStream = Nothing astrRows = Split(strText, vbCrLf) With ThisWorkbook For ialngRow = LBound(astrRows) To UBound(astrRows) astrItems = Split(astrRows(ialngRow), ";") astrItems(0) = Convert(astrItems(0)) For Each objWorksheet In .Worksheets If objWorksheet.Name = astrItems(0) Then Exit For Next If objWorksheet Is Nothing Then Set objWorksheet = .Worksheets.Add(After:=.Worksheets(.Worksheets.Count)) objWorksheet.Name = astrItems(0) blnNewWorksheet = True Else blnNewWorksheet = False End If With objWorksheet If blnNewWorksheet Then .Cells(1, 1).Value = astrItems(0) .Cells(1, 2).Value = CDate(astrItems(1)) .Cells(1, 3).Value = astrItems(2) Else .Cells(1, .Columns.Count).End(xlToLeft).Offset(0, 1).Value = astrItems(2) End If End With Set objWorksheet = Nothing Next End With Else Call MsgBox("Die Textdatei ist leer.", vbExclamation, "Hinweis") End If End Sub Private Function Convert(ByVal strText As String) As String strText = Replace$(strText, "Ã", "Ä") strText = Replace$(strText, "Ã", "Ö") strText = Replace$(strText, "Ã", "Ü") strText = Replace$(strText, "Ã¤", "ä") strText = Replace$(strText, "Ã¶", "ö") strText = Replace$(strText, "Ã¼", "ü") strText = Replace$(strText, "Ã", "ß") Convert = strText End Function

Option Explicit Public Sub Read_TXT() Const TXT_PATH As String = "H:\221007\Test.txt" ' Pfad anpassen !!! Const FOR_READING As Long = 1, FOR_WRITING As Long = 2 Const TRISTATE_USEDEFAULT As Long = -2 Dim objFileSystemObject As Object, objFile As Object, objTextStream As Object Dim objWorksheet As Worksheet, objCell As Range Dim strText As String, astrRows() As String, astrItems() As String Dim ialngRow As Long Dim blnNewWorksheet As Boolean If FileLen(TXT_PATH) > 0 Then Set objFileSystemObject = CreateObject(Class:="Scripting.FileSystemObject") Set objFile = objFileSystemObject.GetFile(TXT_PATH) Set objTextStream = objFile.OpenAsTextStream(FOR_READING, TRISTATE_USEDEFAULT) strText = objTextStream.ReadAll Call objTextStream.Close Set objTextStream = objFile.OpenAsTextStream(FOR_WRITING, TRISTATE_USEDEFAULT) Call objTextStream.Write(vbNullString) Call objTextStream.Close Set objFileSystemObject = Nothing Set objFile = Nothing Set objTextStream = Nothing astrRows = Split(strText, vbCrLf) With ThisWorkbook For ialngRow = LBound(astrRows) To UBound(astrRows) astrItems = Split(astrRows(ialngRow), ";") astrItems(0) = Convert(astrItems(0)) For Each objWorksheet In .Worksheets If objWorksheet.Name = astrItems(0) Then Exit For Next If objWorksheet Is Nothing Then Set objWorksheet = .Worksheets.Add(After:=.Worksheets(.Worksheets.Count)) objWorksheet.Name = astrItems(0) blnNewWorksheet = True Else blnNewWorksheet = False End If With objWorksheet If blnNewWorksheet Then .Cells(1, 1).Resize(1, 3).Value = Array(astrItems(0), CDate(astrItems(1)), astrItems(2)) Else For Each objCell In .Range(.Cells(1, 2), .Cells(.Rows.Count, 2).End(xlUp)) If objCell.Value = CDate(astrItems(1)) Then .Cells(objCell.Row, .Columns.Count).End(xlToLeft).Offset(0, 1).Value = astrItems(2) Exit For End If Next If objCell Is Nothing Then .Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0).Resize(1, 3).Value = Array(astrItems(0), CDate(astrItems(1)), astrItems(2)) Else Set objCell = Nothing End If End If End With Set objWorksheet = Nothing Next End With Else Call MsgBox("Die Textdatei ist leer.", vbExclamation, "Hinweis") End If End Sub Private Function Convert(ByVal strText As String) As String strText = Replace$(strText, "Ã", "Ä") strText = Replace$(strText, "Ã", "Ö") strText = Replace$(strText, "Ã", "Ü") strText = Replace$(strText, "Ã¤", "ä") strText = Replace$(strText, "Ã¶", "ö") strText = Replace$(strText, "Ã¼", "ü") strText = Replace$(strText, "Ã", "ß") Convert = strText End Function

Hallo Michael,
kein Problem:


Option Explicit
Public Sub Read_TXT()
Const TXT_PATH As String = "H:\221007\Test.txt" ' Pfad anpassen !!!
Const FOR_READING As Long = 1, FOR_WRITING As Long = 2
Const TRISTATE_USEDEFAULT As Long = -2
Dim objFileSystemObject As Object, objFile As Object, objTextStream As Object
Dim objWorksheet As Worksheet, objCell As Range
Dim strText As String, astrRows() As String, astrItems() As String
Dim ialngRow As Long
Dim blnNewWorksheet As Boolean
If FileLen(TXT_PATH) > 0 Then
Set objFileSystemObject = CreateObject(Class:="Scripting.FileSystemObject")
Set objFile = objFileSystemObject.GetFile(TXT_PATH)
Set objTextStream = objFile.OpenAsTextStream(FOR_READING, TRISTATE_USEDEFAULT)
strText = objTextStream.ReadAll
Call objTextStream.Close
Set objTextStream = objFile.OpenAsTextStream(FOR_WRITING, TRISTATE_USEDEFAULT)
Call objTextStream.Write(vbNullString)
Call objTextStream.Close
Set objFileSystemObject = Nothing
Set objFile = Nothing
Set objTextStream = Nothing
astrRows = Split(strText, vbCrLf)
With ThisWorkbook
For ialngRow = LBound(astrRows) To UBound(astrRows)
If Trim$(astrRows(ialngRow))  vbNullString Then
astrItems = Split(astrRows(ialngRow), ";")
astrItems(0) = Convert(astrItems(0))
For Each objWorksheet In .Worksheets
If objWorksheet.Name = astrItems(0) Then Exit For
Next
If objWorksheet Is Nothing Then
Set objWorksheet = .Worksheets.Add(After:=.Worksheets(.Worksheets.Count))
objWorksheet.Name = astrItems(0)
blnNewWorksheet = True
Else
blnNewWorksheet = False
End If
With objWorksheet
If blnNewWorksheet Then
.Cells(1, 1).Resize(1, 3).Value = Array(astrItems(0), CDate(astrItems(1)), astrItems(2))
Else
For Each objCell In .Range(.Cells(1, 2), .Cells(.Rows.Count, 2).End(xlUp))
If objCell.Value = CDate(astrItems(1)) Then
.Cells(objCell.Row, .Columns.Count).End(xlToLeft).Offset(0, 1).Value = astrItems(2)
Exit For
End If
Next
If objCell Is Nothing Then
.Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0).Resize(1, 3).Value = Array(astrItems(0), CDate(astrItems(1)), astrItems(2))
Else
Set objCell = Nothing
End If
End If
End With
Set objWorksheet = Nothing
End If
Next
End With
Else
Call MsgBox("Die Textdatei ist leer.", vbExclamation, "Hinweis")
End If
End Sub
Private Function Convert(ByVal strText As String) As String
strText = Replace$(strText, "Ã", "Ä")
strText = Replace$(strText, "Ã", "Ö")
strText = Replace$(strText, "Ã", "Ü")
strText = Replace$(strText, "Ã¤", "ä")
strText = Replace$(strText, "Ã¶", "ö")
strText = Replace$(strText, "Ã¼", "ü")
strText = Replace$(strText, "Ã", "ß")
Convert = strText
End Function

Gruß
Nepumuk

let Quelle = Csv.Document(File.Contents("C:\Pfad\Datei.TXT"),[Delimiter=";", Columns=4, Encoding=65001, QuoteStyle=QuoteStyle.None]), #"Geänderter Typ" = Table.TransformColumnTypes(Quelle,{{"Column1", type text}, {"Column2", type date}, {"Column3", type text}, {"Column4", type text}}), #"Gruppierte Zeilen" = Table.Group(#"Geänderter Typ", {"Column1","Column2"}, {{"Auftrag", each Text.Combine([Column3], "#"), type text}}), #"Spalte nach Trennzeichen teilen" = Table.SplitColumn(#"Gruppierte Zeilen", "Auftrag", Splitter.SplitTextByDelimiter("#", QuoteStyle.None), {"Auftrag 1", "Auftrag 2", "Auftrag 3", "Auftrag 4", "Auftrag 5", "Auftrag 6", "Auftrag 7", "Auftrag 8", "Auftrag 9", "Auftrag 10"}), #"Umbenannte Spalten" = Table.RenameColumns(#"Spalte nach Trennzeichen teilen",{{"Column1", "Name"}, {"Column2", "Datum"}}) in #"Umbenannte Spalten"

Beliebteste Forumthreads (12 Monate)

TXT-Datei zeilenweise verarbeiten

19 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

19
Beiträge zum Forumthread

Beiträge zu diesem Forumthread