Option Explicit
Private Sub DateienSplitten()
Dim TxtIn$(), Arr$()
Dim a&, b&, count&
If Not OpenTxt(TxtIn, ThisWorkbook.Path & "\Test.txt") Then
MsgBox "Pfad falsch!", vbCritical
Exit Sub
End If
ReDim Arr(2)
For a = 1 To UBound(TxtIn)
Arr(b) = TxtIn(a)
b = b + 1
If b = UBound(Arr) Then
MakeFile ThisWorkbook.Path & "\Teil" & count & ".txt", Arr
count = count + 1
b = 0
End If
Next
End Sub
Function OpenTxt(FileData$(), ByVal FileName$) As Boolean
On Error GoTo BadData
Dim FileNum%, Fields$, I&
FileNum = FreeFile
ReDim FileData(0 To 0)
Open FileName For Input As FileNum
Do While Not EOF(FileNum)
Line Input #FileNum, Fields
ReDim Preserve FileData(0 To I)
FileData(I) = Fields
I = I + 1
Loop
Close
FileName = 0
Fields = 0
I = 0
OpenTxt = True
Exit Function
BadData:
End Function
Function KillFile(Path$)
On Error Resume Next
Kill Path
End Function
Function MakeFile( _
ByVal FileName$, ByRef FileLines$(), _
Optional ByVal Overwrite As Boolean = True)
Dim FileNum%, I&, j%, TextOfLine$
FileNum = FreeFile
If Overwrite Then KillFile (FileName)
Open FileName For Append As #FileNum
For I = LBound(FileLines) To UBound(FileLines)
Print #FileNum, FileLines(I)
Next
Close #FileNum
End Function