AW: Dateiname auslesen bzw. anzeigen
02.03.2016 15:19:54
Steve
Hallo Stephan,
ich habe deinen Code mal an die richtigen Stellen verschoben. Du hast im Prinzip nur den Blattschutz aufgehoben und den Bereich gesäubert, das muss nach der Auswahl der Datei, aber vor dem Import erfolgen. Den Blattschutz wieder zu aktivieren darf natürlich erst hinterher geschehen:
Sub Dateiimport()
Dim myFileAddress As Variant
Application.ScreenUpdating = False
Application.Calculation = xlManual
Const StandardVerzeichnis = "angepasst\"
' Standard-Verzeichnis festlegen
ChDrive Left(StandardVerzeichnis, 1)
ChDir StandardVerzeichnis
' Dateiimport
myFileAddress = Application.GetOpenFilename("Text-Dateien (*.txt), *.txt")
If myFileAddress = False Then GoTo Finish
'Blattschutz aufheben, Bereich säubern
ActiveSheet.Unprotect
Range("R3:R249").ClearContents
ActiveWorkbook.RefreshAll
With ActiveSheet.QueryTables.Add(Connection:="TEXT;" & myFileAddress, Destination:=Range("G1"))
.Name = myFileAddress
'
Optionen am besten über Makro-Rekorder und manuelles Importieren ermitteln
'und einfügen (auf deine Datei anpassen)
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = 852
.TextFileStartRow = 2
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = True
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = True
.TextFileSpaceDelimiter = False
.TextFileColumnDataTypes = Array(1, 1, 2, 1, 1, 1)
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
.Delete 'Query im Namensmanager und unter Verbindungen wieder entfernen
End With
Range("A25") = CStr(myFileAddress) 'Dateinamen merken
'Blattschutz setzen
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
Finish:
Application.ScreenUpdating = True
Application.Calculation = xlAutomatic
End Sub
lg Steve