Hi,

einfach&geschmacklos - aufgebohrt

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

Gruß H27