guck
Option Explicit
Sub TxtImport()
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 = "Besitzer weg"
For Each c In Range([B2], [B2].End(xlDown))
c.FormulaR1C1 = Replace(c.FormulaR1C1, mRemoveStr, "")
Next c
'
mErrorStrng = "sortieren ud filtern"
With tSh.Sort
.SortFields.Clear
.SortFields.Add Key:=Range([A2], [A2].End(xlDown))
.SortFields.Add Key:=Range([B2], [B2].End(xlDown))
.SortFields.Add Key:=Range([C2], [C2].End(xlDown))
End With
With tSh.Sort
.SetRange Range([A1], [C1].End(xlDown))
.Header = xlYes
.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
|