AW: Datum v. Text Importe werden nicht sortiert
06.10.2018 15:27:37
Sepp
Hallo Stefan,
auf die Schnelle.
Modul Modul1
Option Explicit
Sub importFromTextFiles()
Const cstrDirectory As String = "P:\bla\bla\" 'Stammverzeichnis - Anpassen!"
Const clngLastCol As Long = 19 'Spaltennummer der letzten Spalte
Dim strPath As String, varData() As Variant, varTemp As Variant
Dim lngCount As Long, lngIndex As Long, lngN As Long, lngNext As Long, FF As Integer
Dim strFile As String, strTmp As String
With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = cstrDirectory
.Title = "Daten-Import Ordnerauswahl daher keine Dateianzeige !"
.ButtonName = "Datenimport starten"
.InitialView = msoFileDialogViewList
If .Show = -1 Then
strPath = .SelectedItems(1)
If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
End If
End With
If Len(strPath) Then
If MsgBox("Datenimport starten ?", vbQuestion + vbYesNo) = vbYes Then
lngCount = countFiles(strPath, "*.txt", True)
If lngCount > 0 Then
Redim varData(1 To lngCount, 1 To clngLastCol)
strFile = Dir(strPath & "*.txt", vbNormal)
Do While strFile <> ""
FF = FreeFile
Open strPath & strFile For Input As #FF
Input #FF, strTmp
Close #FF
If Len(strTmp) Then
varTemp = Split(strTmp, ";")
lngIndex = lngIndex + 1
For lngN = 1 To Ubound(varTemp) + 1
If IsDate(varTemp(lngN - 1)) And lngN = 1 Then
varData(lngIndex, lngN) = CDate(varTemp(lngN - 1))
Else
varData(lngIndex, lngN) = varTemp(lngN - 1)
End If
Next
End If
strFile = Dir
Loop
Kill strPath & "*.txt"
With Sheets("Datenbank") 'Tabellenname evtl. anpassen!
lngNext = Application.Max(3, .Cells(.Rows.Count, 1).End(xlUp).Row + 1)
.Cells(lngNext, 1).Resize(Ubound(varData, 1), Ubound(varData, 2)) = varData
End With
MsgBox "Daten wurden importiert!", vbInformation
Else
MsgBox "Keine Daten zum Import vorhanden!", vbExclamation
End If
End If
End If
End Sub
Private Function countFiles(ByVal Directory As String, Optional ByVal FileName As String = "", _
Optional ByVal SubFolders As Boolean = False) As Long
Dim objFSO As Object, objFolder As Object, objFile As Object, objSubF As Object
Dim lngCount As Long
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.GetFolder(Directory)
If Len(FileName) Then
For Each objFile In objFolder.Files
If objFile.Name Like FileName Then lngCount = lngCount + 1
Next
Else
lngCount = objFolder.Files.Count
End If
If SubFolders Then
For Each objSubF In objFolder.SubFolders
lngCount = lngCount + countFiles(objSubF.Path, FileName, SubFolders)
Next
End If
countFiles = lngCount
Set objSubF = Nothing
Set objFile = Nothing
Set objFolder = Nothing
Set objFSO = Nothing
End Function
VBA/HTML-CodeConverter, AddIn für Office 2002-2016 - in VBA geschrieben von Lukas Mosimann. Projektbetreuung:RMH Software & Media
Code erstellt und getestet in Office 16 - mit VBAHTML 12.6.0