Daten in TXT File vergleichen

Hallo alle zusammen,
Der Aufbau der TEXT Datei sieht wie folgt aus (Trennzeichen ist ein Doppelpunkt):
3334445556:N-....wwweeeeeeeeeeeeeeeeeeeeeeeeeeeeeeee
A10A:Test1:1
B10B:Test2:2
C10C:Test3:3
A10A:Test1:1
A10A:Test3:3
C10C:Test3:3
Gibt es eine VBA Möglichkeit, die Daten bis zum 2. Doppelpunkt zu vergleichen und die Werte nach dem 2. Doppelpunkt zu summieren?
Die erste Zeile muss nicht wieder gegeben werden.
So wie nachfolgend dargestellt soll es dann aussehen, wobei die Daten bis zum ersten Trennzeichen in SpalteA stehen sollen,
nach dem 1. Trennzeichen in SpalteD und nach dem 2. Trennzeichen in SpalteF.
Userbild

Hier die TXT Datei https://www.herber.de/bbs/user/126830.txt
Und hier die Exceldatei https://www.herber.de/bbs/user/126832.xls
Ich hoffe mir kann jemand helfen!
Vielen Dank im Voraus!
MFG Andre

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Option Explicit Sub SumText() Dim strFile As String, strTemp As String Dim varIn As Variant, varOut As Variant, varTemp As Variant Dim lngI As Long, lngJ As Long, varRet1 As Variant, varRet2 As Variant, varRet3 As Variant strFile = "D:\Downloads\forum\126830.txt" strTemp = TextReadAll(strFile) If Len(strTemp) Then varTemp = Split(strTemp, vbLf) If Ubound(varTemp) > 0 Then Redim varIn(Ubound(varTemp) - 1) For lngI = 1 To Ubound(varTemp) If Len(varTemp(lngI)) Then varIn(lngI - 1) = Split(varTemp(lngI), ":") Next End If Redim varOut(1 To Ubound(varIn, 1) + 1, 1 To 7) For lngI = 0 To Ubound(varIn, 1) If IsArray(varIn(lngI)) Then varRet1 = Application.VLookup(varIn(lngI)(0), varOut, 1, 0) varRet2 = Application.VLookup(varIn(lngI)(0), varOut, 4, 0) varRet3 = Application.VLookup(varIn(lngI)(0), varOut, 7, 0) If CStr(varRet1) = varIn(lngI)(0) And CStr(varRet2) = varIn(lngI)(1) Then varOut(varRet3, 6) = varOut(varRet3, 6) + CLng(varIn(lngI)(2)) Else lngJ = lngJ + 1 varOut(lngJ, 1) = varIn(lngI)(0) varOut(lngJ, 4) = varIn(lngI)(1) varOut(lngJ, 6) = CLng(varIn(lngI)(2)) varOut(lngJ, 7) = lngJ End If End If Next Redim Preserve varOut(1 To Ubound(varOut), 1 To 6) Range("A1").Resize(Ubound(varOut, 1), 6) = varOut End If End Sub Private Function TextReadAll(ByVal FileName As String, Optional ByVal MaxLength As Long = 0) As String Dim FF As Integer, strText As String On Error Resume Next If Dir(FileName, vbNormal) <> "" Then FF = FreeFile Open FileName For Binary As #FF If MaxLength <= 0 Then MaxLength = LOF(FF) If MaxLength > LOF(FF) Then MaxLength = LOF(FF) strText = Space$(MaxLength) Get #FF, , strText Close #FF TextReadAll = strText End If On Error GoTo 0 Err.Clear End Function VBA/HTML-CodeConverter, AddIn für Office 2002-2016 - in VBA geschrieben von Lukas Mosimann. Projektbetreuung:RMH Software & Media Code erstellt und getestet in Office 16 - mit VBAHTML 12.6.0

Hallo Andre,
stimmt, habe ich korrigiert.
Modul Modul1

Option Explicit 
 
Sub SumText() 
  Dim strFile As String, strTemp As String 
  Dim varIn As Variant, varOut As Variant, varTemp As Variant 
  Dim lngI As Long, lngJ As Long, varRet1 As Variant, varRet2 As Variant 
    
  strFile = "D:\Downloads\forum\126836.txt" 
    
  strTemp = TextReadAll(strFile) 
    
  If Len(strTemp) Then 
    varTemp = Split(strTemp, vbLf) 
    If Ubound(varTemp) > 0 Then 
      Redim varIn(Ubound(varTemp) - 1) 
      For lngI = 1 To Ubound(varTemp) 
        If Len(varTemp(lngI)) Then varIn(lngI - 1) = Split(varTemp(lngI), ":") 
      Next 
    End If 
    Redim varTemp(1 To Ubound(varIn, 1), 1 To 3) 
    For lngI = 0 To Ubound(varIn, 1) 
      If IsArray(varIn(lngI)) Then 
        varRet1 = Application.VLookup(varIn(lngI)(0) & ":" & varIn(lngI)(1), varTemp, 1, 0) 
        varRet2 = Application.VLookup(varIn(lngI)(0) & ":" & varIn(lngI)(1), varTemp, 3, 0) 
        If CStr(varRet1) = varIn(lngI)(0) & ":" & varIn(lngI)(1) Then 
          varTemp(varRet2, 2) = varTemp(varRet2, 2) + CLng(varIn(lngI)(2)) 
        Else 
          lngJ = lngJ + 1 
          varTemp(lngJ, 1) = varIn(lngI)(0) & ":" & varIn(lngI)(1) 
          varTemp(lngJ, 2) = CLng(varIn(lngI)(2)) 
          varTemp(lngJ, 3) = lngJ 
        End If 
      End If 
    Next 
    Redim varOut(1 To Ubound(varTemp), 1 To 6) 
    For lngI = 1 To Ubound(varTemp, 1) 
      If Len(varTemp(lngI, 1)) Then 
        varOut(lngI, 1) = Split(varTemp(lngI, 1), ":")(0) 
        varOut(lngI, 4) = Split(varTemp(lngI, 1), ":")(1) 
        varOut(lngI, 6) = varTemp(lngI, 2) 
      End If 
    Next 
    Range("A1").Resize(Ubound(varOut, 1), 6) = varOut 
  End If 
  
End Sub 
 
Private Function TextReadAll(ByVal FileName As String, Optional ByVal MaxLength As Long = 0) As String 
  Dim FF As Integer, strText As String 
 
  On Error Resume Next 
 
  If Dir(FileName, vbNormal) <> "" Then 
    FF = FreeFile 
    Open FileName For Binary As #FF 
    If MaxLength <= 0 Then MaxLength = LOF(FF) 
    If MaxLength > LOF(FF) Then MaxLength = LOF(FF) 
    strText = Space$(MaxLength) 
    Get #FF, , strText 
    Close #FF 
    TextReadAll = strText 
  End If 
 
  On Error GoTo 0 
  Err.Clear 
End Function 

VBA/HTML-CodeConverter, AddIn für Office 2002-2016 - in VBA geschrieben von Lukas Mosimann. Projektbetreuung:RMH Software & Media
Code erstellt und getestet in Office 16 - mit VBAHTML 12.6.0

	A	B	C	D	E	F
1	Gruß Sepp
2
3

Beliebteste Forumthreads (12 Monate)

5 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

5
Beiträge zum Forumthread

Beiträge zu diesem Forumthread