' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************
Option Explicit
Sub importTXT()
Dim objADO As Object, objRS As Object
Dim strPath As String, strFile As String, strSQL As String
Dim lngI As Long
With Application.FileDialog(msoFileDialogFilePicker)
.InitialFileName = "E:\Forum"
.Title = "Datei auswählen"
.ButtonName = "Import Starten"
.Filters.Clear
.Filters.Add "Text Dateien", "*.txt; *.csv", 1
.Filters.Add "Alle Dateien", "*.*", 2
.FilterIndex = 1
.InitialView = msoFileDialogViewList
If .Show = -1 Then strFile = .SelectedItems(1)
End With
strPath = Mid(strFile, 1, InStrRev(strFile, "\"))
strFile = Mid(strFile, InStrRev(strFile, "\") + 1)
If Len(strFile) Then
With Sheets("Tabelle1")
.UsedRange.ClearContents
If MakeSchemaINI(strFile, strPath) Then
Set objADO = CreateObject("ADODB.CONNECTION")
objADO.Open "Provider=Microsoft.Jet.OLEDB.4.0; Data Source=" & strPath & _
"; Extended Properties=""text; HDR=Yes; FMT=Delimited; IMEX=1;"""
Set objRS = CreateObject("ADODB.RECORDSET")
strSQL = "SELECT [Teil3],[Beschreibung3],[Teil1],[Beschreibung1] From [" & strFile & "]"
objRS.Open strSQL, objADO, 3, 1, 1
If Not objRS.EOF Then
For lngI = 1 To objRS.Fields.Count
.Cells(1, lngI) = objRS.Fields(lngI - 1).Name
Next
.Cells(2, 1).CopyFromRecordset objRS
End If
objRS.Close
objADO.Close
End If
.Columns.AutoFit
End With
End If
End Sub
Private Function MakeSchemaINI(FileName As String, Path As String) As Boolean
Dim strFile As String, strText As String
Dim ff As Integer
MakeSchemaINI = True
On Error GoTo ErrExit
If Right(Path, 1) <> "\" Then Path = Path & "\"
strFile = Path & "Schema.ini"
strText = "[" & FileName & "]" & vbCrLf & _
"Format=Delimited(;)" & vbCrLf & _
"ColNameHeader=True" & vbCrLf & _
"MaxScanRows=0" & vbCrLf
ff = FreeFile
Open strFile For Output As #ff
Print #ff, strText;
Close #ff
Exit Function
ErrExit:
MakeSchemaINI = False
End Function
