Textdatei nach Excel mit Kriterium

Hallo,
ich hatte schon mal zu diesem Problem gepostet, aber die angebotenen Lösungen waren leider nicht ideal bzw. ich hatte keine Mustervorlage zur Verfügung gestellt. Deshalb nochmal meine hoffentlich konkrete Fragestellung. Ich habe eine Textdatei mit mehr als 70.000 Datenzeilen, von denen ich in Excel aber nur einen kleinen Auszug benötige (nur so rund 50 Datenzeilen!!!). Die Textdatei soll also schon beim Import so beschnitten werden, dass auch Excel 2003 keine Probleme macht.
Öffnet man die Textdatei in Excel, dann wird die Tabelle automatisch in Spaltenform dargestellt.
Folgende Importkriterien sollen gelten:
Nur Datenzeilen, die in Spalte B eine "0" aufweisen sind relevant (oder umgekehrt: alle Datenzeilen mit "1" sind irrelevant) und aus dieser Restmenge benötige ich dann nur noch den 1. Datensatz des jeweiligen Datenblockes. Ein Datenblock ist dabei gekennzeichnet durch eine Kombination aus Spalte A und Spalte K (in der Mustervorlage also "636 1" , "636 62" und "876 1). Am Ende sollten aus der Textdatei in Excel also nur noch die Zeilen 1, 9 und 14 übrigbleiben.
Achtung: Öffnet man die Textdatei im Notepad-Editor, dann wird zumindest die Spalte B in anderer Formatierung angezeigt ("0000" statt "0") beispielsweise. Keine Ahnung, ob dies ein Problem sein könnte.
Hier die Vorlage zum Probieren:
https://www.herber.de/bbs/user/72051.txt
Viele Grüße
Bernd

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Benutzer

Option Explicit Sub Lese_TxT() Dim sFilename$, sInhalt$, oDic As Object Dim ArrayData, tmpArray, ArrayAusgabe() Dim F% Dim A&, B& sFilename = Application.GetOpenFilename("Text Files (*.txt),*.txt") If Dir$(sFilename, vbNormal) = "" Then Exit Sub 'keine Datei F = FreeFile Open sFilename For Binary As #F sInhalt = Space$(LOF(F)) Get #F, , sInhalt Close Do While InStr(sInhalt, " ") > 0 sInhalt = Replace(sInhalt, " ", " ") Loop ArrayData = Split(sInhalt, vbCrLf) sInhalt = "" If Ubound(ArrayData) = -1 Then Exit Sub 'keine Daten Redim Preserve ArrayAusgabe(1 To 2, 1 To Ubound(ArrayData) + 1) Set oDic = CreateObject("Scripting.Dictionary") For A = Lbound(ArrayData) To Ubound(ArrayData) tmpArray = Split(ArrayData(A), Chr(32)) If Ubound(tmpArray) > 10 Then If tmpArray(2) = "0000" Then If Not oDic.exists(tmpArray(1) & "-" & tmpArray(11)) Then B = B + 1 ArrayAusgabe(1, B) = tmpArray(1) ArrayAusgabe(2, B) = tmpArray(11) oDic(tmpArray(1) & "-" & tmpArray(11)) = 0 End If End If End If Next A Redim Preserve ArrayAusgabe(1 To 2, 1 To B) With Sheets("Tabelle1") 'Tabelle anpassen .Range("A2", .Cells(.Rows.Count, 2)).ClearContents With .Range("A2").Resize(B, 2) .Cells = Application.Transpose(ArrayAusgabe) 'hier evtl. Formatierungen End With End With End Sub

Option Explicit Sub Lese_TxT() Dim sFilename$, sInhalt$, oDic As Object Dim ArrayData, tmpArray, ArrayAusgabe(), varValue Dim F% Dim B&, C& sFilename = Application.GetOpenFilename("Text Files (*.txt),*.txt") If Dir$(sFilename, vbNormal) = "" Then Exit Sub 'keine Datei F = FreeFile Open sFilename For Binary As #F sInhalt = Space$(LOF(F)) Get #F, , sInhalt Close Do While InStr(sInhalt, " ") > 0 sInhalt = Replace(sInhalt, " ", " ") Loop ArrayData = Split(sInhalt, vbCrLf) sInhalt = "" If Ubound(ArrayData) = -1 Then Exit Sub 'keine Daten Redim Preserve ArrayAusgabe(1 To 11, 1 To Ubound(ArrayData) + 1) Set oDic = CreateObject("Scripting.Dictionary") For Each varValue In ArrayData tmpArray = Split(varValue, Chr(32)) If Val(tmpArray(2)) = 0 Then If Not oDic.exists(tmpArray(1) & "-" & tmpArray(11)) Then B = B + 1 For C = 1 To 11 ArrayAusgabe(C, B) = tmpArray(C) Next C oDic(tmpArray(1) & "-" & tmpArray(11)) = 0 End If End If Next varValue Redim Preserve ArrayAusgabe(1 To 11, 1 To B) With Application .ScreenUpdating = False .Calculation = xlCalculationManual .EnableEvents = False With Sheets("Tabelle1") 'Tabelle anpassen .Range("A2", .Cells(.Rows.Count, 2)).ClearContents With .Range("A2").Resize(B, 2) .Cells = Application.Transpose(ArrayAusgabe) 'hier evtl. Formatierungen End With End With .EnableEvents = True .Calculation = xlCalculationAutomatic .ScreenUpdating = True End With End Sub

Hallo,
dann sind wahrscheinlich nicht alle Zeilen ausgefüllt.
Versuch mal diese Variante.

Option Explicit

Sub Lese_TxT()
Dim sFilename$, sInhalt$, oDic As Object
Dim ArrayData, tmpArray, ArrayAusgabe(), varValue
Dim F%
Dim B&, C&

Const TrennZ As String = " "
Const dTrennZ As String = TrennZ & TrennZ

sFilename = Application.GetOpenFilename("Text Files (*.txt),*.txt")

If Dir$(sFilename, vbNormal) = "" Then Exit Sub 'keine Datei 

F = FreeFile
Open sFilename For Binary As #F
sInhalt = Space$(LOF(F))
Get #F, , sInhalt
Close
With CreateObject("Vbscript.Regexp")
    .Pattern = dTrennZ
    .Global = True

    Do While .test(sInhalt)
        sInhalt = .Replace(sInhalt, TrennZ)
    Loop
End With

ArrayData = Split(sInhalt, vbCrLf)
sInhalt = ""

If Ubound(ArrayData) = -1 Then Exit Sub 'keine Daten 

Redim Preserve ArrayAusgabe(1 To 11, 1 To Ubound(ArrayData) + 1)
Set oDic = CreateObject("Scripting.Dictionary")

For Each varValue In ArrayData
        tmpArray = Split(varValue, Chr(32))
        If Ubound(tmpArray) > 10 Then
            If Val(tmpArray(2)) = 0 Then
                If Not oDic.exists(tmpArray(1) & "-" & tmpArray(11)) Then
                    B = B + 1
                    For C = 1 To 11
                        ArrayAusgabe(C, B) = tmpArray(C)
                    Next C
                    oDic(tmpArray(1) & "-" & tmpArray(11)) = 0
                End If
            End If
        End If
Next varValue

Redim Preserve ArrayAusgabe(1 To 11, 1 To B)

With Application
    .ScreenUpdating = False
    .Calculation = xlCalculationManual
    .EnableEvents = False

        With Sheets("Tabelle1") 'Tabelle anpassen 
            .Range("A2", .Cells(.Rows.Count, 11)).ClearContents
        
            With .Range("A2").Resize(B, Ubound(ArrayAusgabe))
                .Cells = Application.Transpose(ArrayAusgabe)
                'hier evtl. Formatierungen 
            End With
        End With
    
    .EnableEvents = True
    .Calculation = xlCalculationAutomatic
    .ScreenUpdating = True
End With
End Sub

Gruß Tino

Sub ttt() Dim sDaten, arrTmp, arr(1 To 11), arrDaten Dim n As Integer, m As Integer, j As Integer, i As Long Dim oTest As Object Set oTest = CreateObject("Scripting.dictionary") Open ("c:\test\72051.txt") For Input As #1 sDaten = Split(Input(LOF(1), 1), vbCrLf) Close 1 ReDim arrDaten(1 To 11, 1 To UBound(sDaten)) For j = 0 To UBound(sDaten) - 1 n = 0 arrTmp = Split(sDaten(j), " ") For i = 0 To UBound(arrTmp) If arrTmp(i) "" Then n = n + 1 arr(n) = arrTmp(i) End If Next i If arr(2) = "0000" And Not oTest.exists(arr(1) & "|" & arr(11)) Then m = m + 1 oTest(arr(1) & "|" & arr(11)) = 0 For i = 1 To 11 arrDaten(i, m) = arr(i) Next i End If Next j Sheets(1).Cells(1, 1).Resize(m, 11) = WorksheetFunction.Transpose(arrDaten) End Sub

Beliebteste Forumthreads (12 Monate)

Textdatei nach Excel mit Kriterium

13 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

13
Beiträge zum Forumthread

Beiträge zu diesem Forumthread