Sub importCSV()
Dim objADO As Object, objRS As Object
Dim strPath As String, strFile As String, strSQL As String
Dim vntFiles As Variant, vntItem As Variant, objWS As Worksheet, strSheet As String
Dim lngI As Long, lngN As Long, lngRow As Long
With Application.FileDialog(msoFileDialogFilePicker)
.InitialFileName = "E:\Forum"
.Title = "Datei auswählen"
.ButtonName = "Import Starten"
.AllowMultiSelect = True
.Filters.Clear
.Filters.Add "Text Dateien", "*.txt; *.csv", 1
.Filters.Add "Alle Dateien", "*.*", 2
.FilterIndex = 1
.InitialView = msoFileDialogViewList
If .Show = -1 Then
Redim vntFiles(.SelectedItems.Count - 1)
For Each vntItem In .SelectedItems
vntFiles(lngI) = vntItem
lngI = lngI + 1
Next
End If
End With
If lngI > 0 Then
For Each objWS In ThisWorkbook.Worksheets
If objWS.Name Like "Import *" Then
objWS.UsedRange.ClearContents
End If
Next
For lngI = 0 To UBound(vntFiles)
strPath = Mid(vntFiles(lngI), 1, InStrRev(vntFiles(lngI), "\"))
strFile = Mid(vntFiles(lngI), InStrRev(vntFiles(lngI), "\") + 1)
If Len(strFile) Then
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 [PNR], [FP], [TAG], [MELDEZEIT] From [" & strFile & "]"
objRS.Open strSQL, objADO, 3, 1, 1
If Not objRS.EOF Then
strSheet = objRS.Fields(1)
If SheetExist("Import " & strSheet) Then
With Sheets("Import " & strSheet)
lngRow = Application.Max(2, Application.CountA(.Columns(1)) + 1)
If lngRow = 2 Then
For lngN = 1 To objRS.Fields.Count
.Cells(1, lngN) = objRS.Fields(lngN - 1).Name
Next
End If
If lngRow = 2 Or (CDbl(CDate(objRS.Fields(2)) + CDate(objRS.Fields(3))) <> (CDbl(.Cells(2, 3) + .Cells(2, 4)))) Or (objRS.Fields(0) <> .Cells(2, 1)) Then
.Cells(lngRow, 1).CopyFromRecordset objRS
.Columns(3).NumberFormat = "DD.MM.YYYY"
.Columns(4).NumberFormat = "hh:mm:ss"
.Columns(5).NumberFormat = "DD.MM.YYYY hh:mm:ss"
.Cells(1, 5) = "MELDEZEIT2"
.Range(.Cells(2, 5), .Cells(Application.Max(2, Application.CountA(.Columns(1))), 5)).FormulaR1C1 = "=RC[-2]+RC[-1]"
Else
MsgBox "Doppelte Daten für 'FP " & strSheet & "'!" & vbLf & _
"Datei '" & strFile & "' wird übersprungen!"
End If
End With
Else
MsgBox "Keine Tabelle für 'FP " & strSheet & "' gefunden!"
End If
End If
objRS.Close
objADO.Close
End If
End If
Next
End If
Set objADO = Nothing
Set objRS = Nothing
End Sub