Ich habe 1 Ordner. Immer der selbe. Dort kommen aber jeden Tag
mehrere verschiedene txt-Dateien rein. Sobald die importiert
sind, werden die txt gelöscht. Später kommen wieder neue rein.
Also Variante 2.
Hallo kathrina,
nimm eine neue leere Mappe.
Alt+F11, Extras—Verweise, dort das Häkchen setzen bei:
„Microsoft Scripting Runtime“.
Dann Einfügen—Modul, dort den nachstehenden Code reinkopieren.
In der Codezeile:
For Each Datei In GetFiles(„C:\test“, False, „*.txt“)
änderst du „C:\Test“ in deinen Ordnerpfad ab.
Editor schliessen.
In Excel Alt+F8, dann Makro „TextdateienEinlesen“ ausführen lassen.
Gruß
Reinhard
Option Explicit
' Achtung!
' --\> Microsoft Scripting Runtime - Verweis notwendig!
Sub TextdateienEinlesen()
Dim Datei As File, Zei As Long, Satz As String
On Error GoTo Ende
Application.ScreenUpdating = False
Columns(1).ClearContents
Close
For Each Datei In GetFiles("C:\test", False, "\*.txt")
Open Datei For Input As #1
While Not EOF(1)
Zei = Zei + 1
Line Input #1, Satz
Cells(Zei, 1) = Satz
Wend
Close
Next
Range("A1:A" & Zei).TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, \_
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, \_
Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo \_
:=Array(1, 1)
Ende:
If Err.Number 0 Then MsgBox "Fehler bei Zeile " & Zei
Application.ScreenUpdating = True
End Sub
'
Public Function GetFiles(FolderPath As String, scanSubDirectorys As Boolean, Optional \_
SearchPattern As String, Optional SortBy As String) As Collection
' Die MSR - Objekte
Dim objFs As New FileSystemObject
Dim objRootFolder As Folder
Dim objSubFolder As Folder
Dim objFile As File
' Zwischenspeicher für den Rückgabewert der Funktion
Dim HColl As New Collection
Set HColl = Nothing
' Wenn kein Suchmuster angegeben alle Dateien zurückliefern
If SearchPattern = "" Then SearchPattern = "\*"
' Das Ordner-Objekt für den angegebenen Pfad laden
On Error GoTo err01
Set objRootFolder = objFs.GetFolder(FolderPath)
err01:
If Err.Number 0 Then
Set GetFiles = HColl
Exit Function
End If
' Alle Dateien in diesem Ordner durchlaufen
For Each objFile In objRootFolder.Files
' Wenn das Suchmuster übereinstimmt Datei der Collection hinzufügen
If objFile.Name Like SearchPattern Then
HColl.Add objFile
End If
Next
' Wenn angegeben, die Unterordner des Startpfades durchlaufen
If scanSubDirectorys Then
For Each objSubFolder In objRootFolder.SubFolders
' Alle per Rekursion zurückgelieferten Dateien der Hilfscollection hinzufügen
For Each objFile In GetFiles(objSubFolder.Path, scanSubDirectorys, SearchPattern)
HColl.Add objFile
Next
Next
End If
' Wenn angegeben, die Hilfs-Collection sortieren
If SortBy "" Then
Set HColl = SortItemCollection(HColl, SortBy)
End If
' Rückgabewert
Set GetFiles = HColl
End Function
'
Public Function SortItemCollection(col As Collection, strPropertyName) As Collection
Dim colNew As Collection
Dim objCurrent As Object
Dim objCompare As Object
Dim lngCompareIndex As Long
Dim variantCurrent As Variant
Dim variantCompare As Variant
Dim blnGreaterValueFound As Boolean
'make a copy of the collection, ripping through it one item
'at a time, adding to new collection in right order...
Set colNew = New Collection
For Each objCurrent In col
'get value of current item...
variantCurrent = CallByName(objCurrent, strPropertyName, VbGet)
'setup for compare loop
blnGreaterValueFound = False
lngCompareIndex = 0
For Each objCompare In colNew
lngCompareIndex = lngCompareIndex + 1
variantCompare = CallByName(objCompare, strPropertyName, VbGet)
'die Vergleichstypen auf Variant geändert, somit können beliebige Datentypen \_
miteinander verglichen werden
If variantCurrent
Deshalb auch meine Bitte „von null an“ 
