So, ist ja schon ein neuer Tag. :-) Also wie versprochen hier mal eine andere Variante. Liest aus den Dateien zeilenweise den Text und trägt ihn dann ein. Schau mal bitte, ob das klappt oder wieder Fehlermeldungen kommen (sollte eigentlich nicht mehr passieren :-) ). Gruß
Dim dateien()
Option Explicit
Sub DateienLesen()
Call EventsOff
Dim DateiName As String
Dim quelle As String
Dim i As Long
Dim j As Long
Dim zeile As String
Dim inhalt
Dim ende
Dim nr
ReDim dateien(0)
dateien(0) = 0
quelle = "Y:\Eigene Dateien\Bearbeitung\bearbeiten\makro\neu"
Call txtsuchen(quelle)
If dateien(0) = 0 Then
MsgBox "Keine .txt Dateien gefunden!"
Else
'Daten auslesen
For i = 1 To dateien(0)
DateiName = dateien(i)
ende = ActiveSheet.Cells(Rows.Count, 3).End(xlUp).Row
ende = ende + 2
nr = FreeFile()
Open DateiName For Input As #nr
Do While Not EOF(nr)
Line Input #nr, zeile
inhalt = Split(zeile, Chr(9))
For j = 0 To UBound(inhalt)
If IsNumeric(inhalt(j)) Then inhalt(j) = Replace(inhalt(j), ",", ".")
ActiveSheet.Cells(ende, 3 + j) = inhalt(j)
Next j
ende = ende + 1
Loop
Close #nr
Next i
End If
ActiveSheet.Range("C:D").Columns.AutoFit
ActiveSheet.Range("C:D").NumberFormat = "0.000000"
Call EventsOn
End Sub
Public Sub EventsOff()
With Application
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
End With
End Sub
Public Sub EventsOn()
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
End With
End Sub
Function txtsuchen(quelle As String)
Dim suche
Dim ordner()
Dim i As Long
ReDim ordner(0)
ordner(0) = 0
ChDrive (Left(quelle, 3))
ChDir (quelle)
'Ordner durchschauen
suche = Dir(quelle & "\*.*", vbDirectory)
Do Until suche = ""
'Normale Dateien rausfiltern
If (GetAttr(quelle & "\" & suche) = 16) Then
'die hier ankommen, sind Ordner, extra speichern
ordner(0) = ordner(0) + 1
ReDim Preserve ordner(ordner(0))
ordner(ordner(0)) = suche
Else
If Right(suche, 4) = ".txt" Then
dateien(0) = dateien(0) + 1
ReDim Preserve dateien(dateien(0))
dateien(dateien(0)) = quelle & "\" & suche
End If
End If
suche = Dir()
Loop
'jetzt durch die Ordner gehen
For i = 1 To UBound(ordner)
If Dir(ordner(i), vbNormal) = "" And Left(ordner(i), 1) <> "." Then
Call txtsuchen(quelle & "\" & ordner(i))
ChDir (quelle)
End If
Next
End Function
|