Hi Georg,
hier werden nun auch die Spalten 7 bis 9 ausgewertet und Spalte A ausgeblendet:
Option Explicit
Sub TxtLesen_Georg()
Dim arrFiles(1 To 9999) As String, lngF As Long, ii As Long, lngA As Long
Dim strVz As String, strFile As String, strUeb As String, lngZ As Long
Dim wbkTxt As Workbook
strVz = "F:\exc\www\tmp\georg\" ' hier Verzeichnis eintragen
arrFiles(1) = Dir(strVz & "*.txt") ' Liste der Textdateien
Do While arrFiles(lngF + 1) ""
lngF = lngF + 1
arrFiles(lngF + 1) = Dir
Loop
' Abarbeiten der Liste
For ii = 1 To lngF
' Öffnen der Textdatei
Workbooks.OpenText Filename:=strVz & arrFiles(ii), Origin:=xlMSDOS, _
DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, Semicolon:=True, _
FieldInfo:=Array(Array(1, 2), Array(2, 2), Array(3, 2), _
Array(4, 2), Array(5, 2), Array(6, 2), Array(7, 1), _
Array(8, 1), Array(9, 2), Array(10, 4), Array(11, 1))
Set wbkTxt = ActiveWorkbook
' Anzahl neue Zeilen
lngZ = Cells(Rows.Count, 1).End(xlUp).Row
' Name der Excelmappe
strFile = strVz & Left(arrFiles(ii), Len(arrFiles(ii)) - 4) & _
Format(Date, "_yyyy-mm-dd") & ".xls"
If Dir(strFile) "" Then
' Excelmappe existiert bereits
Workbooks.Open strFile
' neue Zeilen kopieren
lngA = Cells(Rows.Count, 1).End(xlUp).Row
wbkTxt.Sheets(1).Rows("1:" & lngZ).Copy Cells(lngA + 1, 1)
TxtLesen_Bereinige lngA + 1, lngA + lngZ ' Bereinigungen
ActiveWorkbook.Close True ' Sichere und schließe Excelmappe
wbkTxt.Close False ' Schließe Textdatei ohne Sichern
Else
' Excelmappe neu anlegen
Rows(1).Insert ' Überschriftzeile
Range("A1:K1") = Split("Key;Kennzeichen;EAN-Nummer;Seriennummer;Bezeichnung 1;" & _
"Bezeichnung 2;Entnahmemenge;Rückgabe/Verkauf;Vertragsnummer;Datum;Uhrzeit", ";")
With Rows(1)
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
Range("G1:H1").Orientation = 90
TxtLesen_Bereinige 2, lngZ + 1 ' Bereinigungen
With ActiveSheet.PageSetup ' Seite einrichten
.PrintTitleRows = "$1:$1" ' Wiederholungszeile 1
.PrintGridlines = True ' Rahmen (Gitternetz)
.Orientation = xlLandscape ' Querformat
.Zoom = False ' kein Zoomfaktor
.FitToPagesWide = 1 ' 1 Seite breit
.FitToPagesTall = False ' Höhe beliebig
End With
With ActiveWorkbook ' Blattname
lngZ = InStr(Cells(2, 2), " ")
If lngZ = 0 Then lngZ = 1
.Sheets(1).Name = "Bewegungen" & Trim(Mid(Cells(2, 2), lngZ))
' neue Mappe sichern
.SaveAs strVz & Left(arrFiles(ii), Len(arrFiles(ii)) - 4) & _
Format(Date, "_yyyy-mm-dd") & ".xls", FileFormat:=xlWorkbookNormal '-4143
.Close False
End With
End If
Next ii
End Sub
Private Sub TxtLesen_Bereinige(zVon As Long, zBis As Long)
Dim zz As Long, rngDel As Range, zDel As Long
' Zeilen löschen, wenn Spalte 9
For zz = zVon To zBis
If Trim(Cells(zz, 9)) "" Then
If rngDel Is Nothing Then
Set rngDel = Cells(zz, 9)
Else
Set rngDel = Union(rngDel, Cells(zz, 9))
End If
End If
Next zz
If Not rngDel Is Nothing Then
zDel = rngDel.Cells.Count ' Anzahl zu löschende Zeilen
rngDel.EntireRow.Delete
End If
Set rngDel = Nothing
' Spalte 7 bedingt leeren
With Application
For zz = zVon To zBis - zDel
If .IsNumber(Cells(zz, 7)) And .IsNumber(Cells(zz, 8)) Then
If rngDel Is Nothing Then
Set rngDel = Cells(zz, 7)
Else
Set rngDel = Union(rngDel, Cells(zz, 7))
End If
End If
Next zz
End With
If Not rngDel Is Nothing Then rngDel.ClearContents
' Sort
Cells(1, 1).Sort Key1:=Cells(2, 1), Order1:=xlAscending, Header:=xlYes
Columns.AutoFit ' Spaltenbreite automatisch
Columns(1).Hidden = True ' Spalte A ausblenden
End Sub
Rückmeldung wäre nett! - Grüße aus Kamp-Lintfort von Erich