Option Explicit
Sub TxtImport()
Const mNoFileStr As String = "\iwaswos.txt\nixdo.xls"
Const mNoExteStr As String = ".abc.123.woswasi"
Dim vgl As String
Const mRemoveStr As String = " Besitzer: "
Const mSourceExt As String = "Dateiendung ist (*.txt), *.txt"""
Dim mSourceFile As String
Dim mErrorStrng As String
Dim tWb As Workbook
Dim sWb As Workbook
Dim tSh As Worksheet
Dim c As Range
On Error GoTo errorhandler
Application.ScreenUpdating = False
Set tWb = ActiveWorkbook
mErrorStrng = "Auswahl ab aktuellem Verzeichnis"
ChDrive Left(ActiveWorkbook.Path, _
InStr(ActiveWorkbook.Path, "\") - 1)
ChDir ActiveWorkbook.Path
mSourceFile = Application.GetOpenFilename(mSourceExt)
If mSourceFile = "Falsch" Then Exit Sub
mErrorStrng = "ein neues Tabellenblatt"
tWb.Sheets.Add After:=tWb.Sheets(tWb.Sheets.Count)
Set tSh = ActiveSheet
mErrorStrng = "Tabellenblatt bereits vorhanden"
tSh.Name = Mid(Replace(mSourceFile, tWb.Path, ""), 2)
mErrorStrng = "Textdatei einlesen und kopieren"
Workbooks.OpenText Filename:=mSourceFile, Origin:=xlMSDOS, _
StartRow:=1, DataType:=xlDelimited, TextQualifier:=xlNone, _
ConsecutiveDelimiter:=False, Tab:=False, Semicolon:=False, Comma:=False _
, Space:=False, Other:=True, OtherChar:="/", _
FieldInfo:=Array(Array(1, 1), Array(2, 1), Array(3, 1)), _
TrailingMinusNumbers:=True
[A1].CurrentRegion.Copy Destination:=tSh.[A2]
mErrorStrng = "Einspielung schließen"
Application.DisplayAlerts = Not Application.DisplayAlerts
ActiveWorkbook.Close
Application.DisplayAlerts = Not Application.DisplayAlerts
mErrorStrng = "Spaltenüberschriften"
With tSh.[A1:C1]
.Font.Size = 9
.Font.Bold = True
.HorizontalAlignment = xlCenter
End With
[A1].FormulaR1C1 = "Pfad"
[B1].FormulaR1C1 = "Besitzer"
[C1].FormulaR1C1 = "Dateigröße"
mErrorStrng = "Prüfung auf Inhalt"
If Range([B1], [B1].End(xlDown)).Count = Rows.Count Then GoTo errorhandler
If Range([B1], [B1].End(xlDown)).Count <= 2 Then GoTo errorhandler
mErrorStrng = "falsche Dateiendung oder nur Besitzer weg"
For Each c In Range([B2], [B2].End(xlDown))
c.FormulaR1C1 = Replace(c.FormulaR1C1, mRemoveStr, "")
vgl = Trim(Mid(c.Offset(0, -1).Value, InStrRev(c.Offset(0, -1).Value, ".")))
If InStr(mNoExteStr, vgl) > 0 Then Rows(c.Row).Clear
If c.Offset(0, -1).Value <> "" Then
vgl = Trim(Mid(c.Offset(0, -1).Value, InStrRev(c.Offset(0, -1).Value, "\")))
If InStr(mNoFileStr, vgl) > 0 Then Rows(c.Row).Clear
End If
Next c
mErrorStrng = "sortieren ud filtern"
With tSh.Sort
.SortFields.Clear
.SortFields.Add Key:=Range("A:A")
.SortFields.Add Key:=Range("B:B")
.SortFields.Add Key:=Range("C:C")
End With
With tSh.Sort
.SetRange Range("A:C")
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
With Range([A:A], [C:C])
.EntireColumn.AutoFit
.AutoFilter
End With
[A1].Select
On Error GoTo 0
Set tWb = Nothing
Set tSh = Nothing
Application.ScreenUpdating = True
Exit Sub
errorhandler:
MsgBox "Abbruch - Fehler bei : " & mErrorStrng
On Error GoTo 0
Set tWb = Nothing
Set tSh = Nothing
Application.ScreenUpdating = True
End Sub