|
Punkt vor dem Cells: Wenn man, wie hier einen With - Verweise setzt, also hier
With ActiveSheet
dann bedeutet der Punkt, daß die Cells() Anweisung eben nur für dieses ActiveSheet gilt. Das muß z.B. NICHT in der Arbeitsmappe mit dem VBA-Code sein, da auch hier With ActiveWorkbook angegeben ist. Beide Anweisungen werden mit End With wieder geschlossen.
Das erspart einem, immer ActiveSheet.Cells() zu schreiben.
vbBinaryCompare heißt, daß der Vergleich im Binärformat, nicht als vbTextCompare stattfindet.
Im Übrigen habe ich den Code noch erweitert, weil es zu viele Zeichenkombinationen geben kann, die einen korrekten Ablauf stören würden. So sollte es weniger Fehleranfällig sein.
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
QSatz = Bereinigen(QSatz)
TSatz = ""
Do
WortAnfangPos = WortEndePos + 1
If Mid(QSatz, WortAnfangPos, 1) = " " Then
If InStr(WortAnfangPos + 1, QSatz, " ", vbBinaryCompare) > _
InStr(WortAnfangPos + 1, QSatz, Chr(10), vbBinaryCompare) _
And InStr(WortAnfangPos + 1, QSatz, Chr(10), vbBinaryCompare) <> 0 Then
WortEndePos = InStr(WortAnfangPos + 1, QSatz, Chr(10), vbBinaryCompare)
Versatz = 1
Else
WortEndePos = InStr(WortAnfangPos + 1, QSatz, " ", vbBinaryCompare)
Versatz = 0
End If
Else
If InStr(WortAnfangPos + 1, QSatz, " ", vbBinaryCompare) > _
InStr(WortAnfangPos + 1, QSatz, Chr(10), vbBinaryCompare) _
And InStr(WortAnfangPos + 1, QSatz, Chr(10), vbBinaryCompare) <> 0 Then
WortEndePos = InStr(WortAnfangPos, QSatz, Chr(10), vbBinaryCompare)
Versatz = 1
Else
WortEndePos = InStr(WortAnfangPos, QSatz, " ", vbBinaryCompare)
Versatz = 0
End If
End If
If WortEndePos <> 0 Then
QWort = Mid(QSatz, WortAnfangPos, WortEndePos - WortAnfangPos)
Else
QWort = Right(QSatz, Len(QSatz) - WortAnfangPos + 1)
End If
TWort = ""
If Left(QWort, 1) = Chr(10) Or Left(QWort, 1) = Chr(13) Or Left(QWort, 1) = " " Then
WortAnfang = Left(QWort, 2)
QWort = Mid(QWort, 3, Len(QWort) - 2)
Else
WortAnfang = Left(QWort, 1)
QWort = Mid(QWort, 2, Len(QWort) - 1)
End If
If Right(QWort, 1) = "," Or Right(QWort, 1) = "." Or Right(QWort, 1) = "!" Or Right(QWort, 1) = "?" Then
WortEnde = Right(QWort, 2)
QWort = Mid(QWort, 1, Len(QWort) - 2)
Else
WortEnde = Right(QWort, 1)
QWort = Mid(QWort, 1, Len(QWort) - 1)
End If
If Len(QWort) = 0 Then
TWort = WortAnfang & WortEnde
If TSatz = "" Then
TSatz = TWort
Else
If Versatz = 0 Then
TSatz = TSatz & " " & TWort
Else
TSatz = TSatz & Chr(10) & TWort
End If
End If
ElseIf Len(QWort) = 1 Then
TWort = WortAnfang & QWort & WortEnde
If TSatz = "" Then
TSatz = TWort
Else
If Versatz = 0 Then
TSatz = TSatz & " " & TWort
Else
TSatz = TSatz & Chr(10) & TWort
End If
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
If Versatz = 0 Then
TSatz = TSatz & " " & TWort
Else
TSatz = TSatz & Chr(10) & TWort
End If
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
Private Function Bereinigen(ByVal WERT As String) As String
Dim LaufZahl As Long
For LaufZahl = 1 To Len(WERT)
If LaufZahl > Len(WERT) Then Exit For
If Mid(WERT, LaufZahl, 1) = " " Then
If Mid(WERT, LaufZahl + 1, 1) = "," Or Mid(WERT, LaufZahl + 1, 1) = "." Or _
Mid(WERT, LaufZahl + 1, 1) = "!" Or Mid(WERT, LaufZahl + 1, 1) = "?" _
Or Mid(WERT, LaufZahl + 1, 1) = Chr(10) Or Mid(WERT, LaufZahl + 1, 1) = Chr(13) _
Or Mid(WERT, LaufZahl + 1, 1) = " " Then
WERT = Left(WERT, LaufZahl - 1) & Right(WERT, Len(WERT) - LaufZahl)
LaufZahl = LaufZahl - 1
End If
End If
Next LaufZahl
For LaufZahl = 1 To Len(WERT)
If LaufZahl > Len(WERT) Then Exit For
If Mid(WERT, LaufZahl, 1) = Chr(10) Or Mid(WERT, LaufZahl, 1) = Chr(13) Then
If Mid(WERT, LaufZahl + 1, 1) = "," Or Mid(WERT, LaufZahl + 1, 1) = "." Or _
Mid(WERT, LaufZahl + 1, 1) = "!" Or Mid(WERT, LaufZahl + 1, 1) = "?" _
Or Mid(WERT, LaufZahl + 1, 1) = " " Or Mid(WERT, LaufZahl + 1, 1) = Chr(10) _
Or Mid(WERT, LaufZahl + 1, 1) = Chr(13) Then
WERT = Left(WERT, LaufZahl) & Right(WERT, Len(WERT) - LaufZahl - 2)
End If
End If
Next LaufZahl
For LaufZahl = 1 To Len(WERT)
If LaufZahl > Len(WERT) Then Exit For
If (Mid(WERT, LaufZahl, 1) = "," Or Mid(WERT, LaufZahl, 1) = "." Or _
Mid(WERT, LaufZahl, 1) = "!" Or Mid(WERT, LaufZahl, 1) = "?") _
And Mid(WERT, LaufZahl + 1, 1) <> " " Then
WERT = Left(WERT, LaufZahl) & " " & Right(WERT, Len(WERT) - LaufZahl)
End If
Next LaufZahl
Bereinigen = WERT
End Function
Im übrigen bitte ich Dich, es künftig zu unterlassen, Dir Deine Hausaufgaben vom Forum machen zu lassen. Das ist weder der Sinn von Hausaufgaben noch der eines Forums. Und ich persönlich komme mir hier verarscht vor! Daß ich mir die Arbeit mache, für die Du zu faul bist sehe ich nicht ein.
Severus
|