Option Explicit

Sub ZufallsText()
Dim Zufall As Integer
Dim Start As Integer
Dim QSatz As String
Dim TSatz As String
Dim QWort As String
Dim TWort As String
Dim WortAnfang As String
Dim WortEnde As String
Dim LaufZahlSatz As Long
Dim WortAnfangPos As Long
Dim WortEndePos As Long
Dim LetzteZeile As Long
Dim Versatz As Long

'Die Texte werden aus der Spalte A gelesen und als Rondom Text in die Spalte B geschrieben.

With ActiveWorkbook
With ActiveSheet
LetzteZeile = .Cells(.Cells.Rows.Count, 1).End(xlUp).Row
WortEndePos = 0
For LaufZahlSatz = 1 To LetzteZeile
QSatz = .Cells(LaufZahlSatz, 1).Text
TSatz = ""
Do
WortAnfangPos = WortEndePos + 1
WortEndePos = InStr(WortAnfangPos, QSatz, " ", vbBinaryCompare)
If WortEndePos <> 0 Then
QWort = Mid(QSatz, WortAnfangPos, WortEndePos - WortAnfangPos)
Else
QWort = Right(QSatz, Len(QSatz) - WortAnfangPos + 1)
End If

TWort = ""
WortAnfang = Left(QWort, 1)
If Right(QWort, 1) = "," Or Right(QWort, 1) = "." Or Right(QWort, 1) = "!" Or Right(QWort, 1) = "?" Then
WortEnde = Right(QWort, 2)
QWort = Mid(QWort, 2, Len(QWort) - 3)
Else
WortEnde = Right(QWort, 1)
QWort = Mid(QWort, 2, Len(QWort) - 2)
End If

If Len(QWort) = 0 Then
TWort = WortAnfang & WortEnde
If TSatz = "" Then
TSatz = TWort
Else
TSatz = TSatz & " " & TWort
End If
ElseIf Len(QWort) = 1 Then
TWort = WortAnfang & QWort & WortEnde
If TSatz = "" Then
TSatz = TWort
Else
TSatz = TSatz & " " & TWort
End If
Else

Do
Zufall = Int((Len(QWort)) * Rnd + 1)
TWort = TWort & Mid(QWort, Zufall, 1)
If Len(QWort) > 2 Then
QWort = Left(QWort, Zufall - 1) & Right(QWort, Len(QWort) - Zufall)
ElseIf Len(QWort) = 2 Then
If Zufall = 1 Then
QWort = Right(QWort, 1)
ElseIf Zufall = 2 Then
QWort = Left(QWort, 1)
End If
End If
If Len(QWort) = 1 Then
TWort = WortAnfang & TWort & QWort & WortEnde
If TSatz = "" Then
TSatz = TWort
Else
TSatz = TSatz & " " & TWort
End If
Exit Do
End If
Loop
End If
If WortEndePos = 0 Then Exit Do
Loop

.Cells(LaufZahlSatz, 2) = TSatz
Next LaufZahlSatz
End With
End With
End Sub

Severus