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
ende2
Dim
name
As
String
Dim
ausgang
As
String
On
Error
Resume
Next
ReDim
dateien(0)
dateien(0) = 0
ausgang = ThisWorkbook.name
quelle =
"C:\Users\ich\Desktop\Programmieung\hallo\Neuer Ordner\neu"
Call
txtsuchen(quelle)
If
dateien(0) = 0
Then
MsgBox
"Keine .txt Dateien gefunden!"
Else
For
i = 1
To
dateien(0)
DateiName = dateien(i)
ende = ActiveSheet.Cells(Rows.Count, 3).
End
(xlUp).Row
ende = ende + 2
Workbooks.OpenText Filename:=DateiName, Origin:=1252
name = ActiveWorkbook.name
ende2 = ActiveSheet.Cells(Rows.Count, 1).
End
(xlUp).Row
ActiveSheet.Range(ActiveSheet.Cells(1, 1), ActiveSheet.Cells(ende2, 3)).Copy Destination:=Workbooks(ausgang).Worksheets(1).Range(Workbooks(ausgang).Worksheets(1).Cells(ende, 3), Workbooks(ausgang).Worksheets(1).Cells(ende + ende2, 5))
Workbooks(ausgang).Activate
Workbooks(name).Close SaveChanges:=
False
Next
i
End
If
Call
tausch
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)
suche = Dir(quelle &
"\*.*"
, vbDirectory)
Do
Until
suche =
""
If
(GetAttr(quelle & "\" & suche) = 16)
Then
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
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
Function
tausch()
Dim
i
As
Long
For
i = 1
To
ActiveSheet.Cells(Rows.Count, 5).
End
(xlUp).Row
ActiveSheet.Cells(i, 5) = Replace(ActiveSheet.Cells(i, 5), Chr(195) & Chr(132),
"Ä"
)
ActiveSheet.Cells(i, 5) = Replace(ActiveSheet.Cells(i, 5), Chr(195) & Chr(164),
"ä"
)
ActiveSheet.Cells(i, 5) = Replace(ActiveSheet.Cells(i, 5), Chr(195) & Chr(150),
"Ö"
)
ActiveSheet.Cells(i, 5) = Replace(ActiveSheet.Cells(i, 5), Chr(195) & Chr(182),
"ö"
)
ActiveSheet.Cells(i, 5) = Replace(ActiveSheet.Cells(i, 5), Chr(195) & Chr(156),
"Ü"
)
ActiveSheet.Cells(i, 5) = Replace(ActiveSheet.Cells(i, 5), Chr(195) & Chr(188),
"ü"
)
ActiveSheet.Cells(i, 5) = Replace(ActiveSheet.Cells(i, 5), Chr(195) & Chr(159),
"ß"
)
Next
i
End
Function