Microsoft Excel

Herbers Excel/VBA-Archiv

Anpassung Makro für Textimport

Betrifft: Anpassung Makro für Textimport von: Bernd
Geschrieben am: 29.01.2008 12:59:40


Hallo,

das u. angeführte Makro liest eine Textdatei insoweit auf, dass nur die erste Zeile pro Position (in Spalte A sind die Positionen hinterlegt) abgegriffen wird, die Usprungsdatei wird damit deutlich verkleinert.
Nun kommt es leider des öfteren zu Datenfehlern in der Form, dass Datensätze mit dem Eintrag "1" in Spalte B angeliefert werden und dieser Datensätze stehen dummerweise an erster Stelle der jeweiligen Position (in Spalte) in der Ursprungsliste. Wie muss ich das Makro anpassen, damit in einem 1. Schritt alle Zeilen aus der Urspungsdatei eliminiert werden, die den Wert "1" in Spalte B enhalten? Die korrekten Datensätze enthalten übrigens den Wert "0".

Viele Grüße,
Bernd

Sub Aufbereitung_Datei()
'
    Dim Ende As Long
    Dim Dateiname
    Cells.Select
    Selection.ClearContents
        
        Dateiname = Application.GetOpenFilename(FileFilter:="textdateien(*.txt),*.txt", _
        Title:="Bitte Textdatei mit Daten öffnen")
    If Dateiname = False Then Exit Sub
    Range("A1").Select
    Application.CommandBars("External Data").Visible = False
    With ActiveSheet.QueryTables.Add(Connection:= _
        "TEXT;" & Dateiname, Destination:=Range("A1"))
        .Name = "ZIRILIST"
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .TextFilePromptOnRefresh = False
        .TextFilePlatform = 850
        .TextFileStartRow = 1
        .TextFileParseType = xlFixedWidth
        .TextFileTextQualifier = xlTextQualifierDoubleQuote
        .TextFileConsecutiveDelimiter = False
        .TextFileTabDelimiter = True
        .TextFileSemicolonDelimiter = False
        .TextFileCommaDelimiter = False
        .TextFileSpaceDelimiter = False
        .TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1)
        .TextFileFixedColumnWidths = Array(4, 5, 11, 16, 8, 20, 11, 21, 17, 12)
        .TextFileTrailingMinusNumbers = True
        .Refresh BackgroundQuery:=False
    End With
Ende = Cells(65536, 1).End(xlUp).Row
Columns(1).Insert
With Range("A2:A" & Ende)
.FormulaR1C1 = "=if(r[-1]c[1]=rc[1],true,row())"
.Formula = .Value
.CurrentRegion.Sort Key1:=Cells(2, 1), order1:=xlAscending, header:=xlYes
.SpecialCells(xlCellTypeConstants, 4).EntireRow.Clear
End With
Columns(1).Delete
Sp = 6 ' Spalte 1 vergleichen
P1 = 50000 ' Bis zu der Zeile 24 vergleichen
P2 = 0 'gelöschte Zeilen zählen auf 0 setzen
For Ze = 2 To P1 ' von zeile 2 bis 24 vergleichen
If Cells(Ze, Sp) = "0" Then ' Leere Zellen löschen , - , "as"
'Zelle mit inhalt as löschen
Cells(Ze, Sp).EntireRow.Delete
Ze = Ze - 1 ' gleiche zeile nochmal testen
P2 = P2 + 1 ' gelöschte Zeilen zählen
End If
If P2 + Ze > P1 Then Exit For
Next Ze
Cells(1, 1).Select
End ' alle variablen löschen makro benden
 Cells.Select
    With Selection.Font
        .Name = "Sparkasse Rg"
        .FontStyle = "Standard"
        .Size = 10
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ColorIndex = xlAutomatic
    End With
End Sub


 

Beiträge aus den Excel-Beispielen zum Thema "Anpassung Makro für Textimport"