Blank in String einfügen, wenn ...

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Günter,
eine (leider recht fehleranfällige) Formellösung könnte so ausschauen:
Tabellenblattname: Tabelle1

	A	B
1	MaxMüller	Max Müller
2	MönchenGladbach	Mönchen Gladbach

Benutzte Formeln:
B1: { =LINKS(A1;MAX(IDENTISCH(TEIL(A1;ZEILE(INDIREKT("2:"&LÄNGE(A1)));1);GROSS(TEIL(A1;ZEILE(INDIREKT("2:"&LÄNGE(A1)));1)))*ZEILE(INDIREKT("2:"&LÄNGE(A1))))-1)&" "&TEIL(A1;MAX(IDENTISCH(TEIL(A1;ZEILE(INDIREKT("2:"&LÄNGE(A1)));1);GROSS(TEIL(A1;ZEILE(INDIREKT("2:"&LÄNGE(A1)));1)))*ZEILE(INDIREKT("2:"&LÄNGE(A1))));100)}
B2: {=LINKS(A2;MAX(IDENTISCH(TEIL(A2;ZEILE(INDIREKT("2:"&LÄNGE(A2)));1);GROSS(TEIL(A2;ZEILE(INDIREKT("2:"&LÄNGE(A2)));1)))*ZEILE(INDIREKT("2:"&LÄNGE(A2))))-1)&" "&TEIL(A2;MAX(IDENTISCH(TEIL(A2;ZEILE(INDIREKT("2:"&LÄNGE(A2)));1);GROSS(TEIL(A2;ZEILE(INDIREKT("2:"&LÄNGE(A2)));1)))*ZEILE(INDIREKT("2:"&LÄNGE(A2))));100)}
enthält Matrixformeln: {} nicht eingeben, sondern Formel mit STRG-SHIFT-ENTER abschließen
Einschränkungen:
Wenn mehrere Großbuchstaben vorkommen, wird nur das Wort nach dem letzten abgeschnitten.
Wenn kein Großbuchstabe vorkommt, gibt's einen #WERT-Fehler
Wenn ein Leerzeichen vorkommt, wird auch dort getrennt (wenn mehrere, beim letzten)
Falls dir die Formelvariante auch zusagt, werde ich mal schauen, ob sich das verfeinern lässt.
Rückmeldung wäre nett.
Gruß
David

Function blank_einfuegen(quellzk As String) As String Dim laenge As Integer Dim buchstabe1 As String Dim buchstabe2 As String Dim x As Integer laenge = Len(quellzk) For x = 1 To (laenge - 1) buchstabe1 = Mid$(quellzk, x, 1) buchstabe2 = Mid$(quellzk, x + 1, 1) If ((buchstabe1 = LCase(buchstabe1)) And (buchstabe2 = UCase(buchstabe2))) Then Exit For End If Next If (x = laenge - 1) Then blank_einfuegen = quellzk Else blank_einfuegen = Mid$(quellzk, 1, x) & " " & Mid$(quellzk, x + 1) End If End Function

Servus Günter,
hiermal abgeändert:


Sub Blank()
Dim i As Long, StellenArray() As Long, x As Long, z As Long, lngLetzte As Long
lngLetzte = Cells(Rows.Count, 1).End(xlUp).Row
For z = 1 To lngLetzte
For i = 2 To Len(Cells(z, 1))
If Mid(Cells(z, 1), i, 1) = UCase(Mid(Cells(z, 1), i, 1)) And Mid(Cells(z, 1), i, 1)  " "  _
And Mid(Cells(z, 1), i, 1)  "ß" Then
ReDim Preserve StellenArray(x)
StellenArray(x) = i
x = x + 1
End If
Next i
On Error Resume Next
For k = UBound(StellenArray()) To LBound(StellenArray()) Step -1
If Mid(Cells(z, 1), StellenArray(k) - 1, 1)  " " And Mid(Cells(z, 1), StellenArray(k) - 1, _
1)  UCase(Mid(Cells(z, 1), StellenArray(k) - 1, 1)) Then
Cells(z, 1) = Left(Cells(z, 1), StellenArray(k) - 1) & " " & Right(Cells(z, 1), Len( _
Cells(z, 1)) - StellenArray(k) + 1)
Else
If Mid(Cells(z, 1), StellenArray(k) - 1, 1) = "ß" Then
Cells(z, 1) = Left(Cells(z, 1), StellenArray(k) - 1) & " " & Right(Cells(z, 1), Len( _
Cells(z, 1)) - StellenArray(k) + 1)
End If
End If
Next k
On Error GoTo 0
x = 0
Next z
End Sub

Allerdings die eierlegende Wollmilchsau kann ich dir nicht liefern. Jetzt wird eben BAHNMAUER nicht mehr getrennt, da man ja keine wirkliche Wortabgrenzung hat. Könnte ja sein:
Bahn mau er
oder
Bahn Mauer
oder
Bahnmauer,
aber woher soll man das wissen. Das kann man nicht auseinanderhalten. Außerdem wird z.B.:
WeißESybille dann so getrennt: Weiß ESybille, weil die Trennbedingungen so sind. WeißeSybille wird dagegen richtig getrennt in Weiße Sybille, aber dagegen kann ich nichts machen, weil irgendetwas brauch ich ja nun als Trennkriterium. Eigenständige Wörter erkennt das Makro nicht.
Gruß
Chris

Sub Blank() Dim i As Long, StellenArray() As Long, x As Long, z As Long, lngLetzte As Long lngLetzte = Cells(Rows.Count, 1).End(xlUp).Row For z = 1 To lngLetzte For i = 2 To Len(Cells(z, 1)) If Mid(Cells(z, 1), i, 1) = UCase(Mid(Cells(z, 1), i, 1)) And Mid(Cells(z, 1), i, 1) " " _ And Mid(Cells(z, 1), i, 1) "ß" Then ReDim Preserve StellenArray(x) StellenArray(x) = i x = x + 1 End If Next i On Error Resume Next For k = UBound(StellenArray()) To LBound(StellenArray()) Step -1 If Mid(Cells(z, 1), StellenArray(k) - 1, 1) " " And Mid(Cells(z, 1), StellenArray(k) - 1, _ 1) UCase(Mid(Cells(z, 1), StellenArray(k) - 1, 1)) Then Cells(z, 1) = Left(Cells(z, 1), StellenArray(k) - 1) & " " & Right(Cells(z, 1), Len( _ Cells(z, 1)) - StellenArray(k) + 1) Else If Mid(Cells(z, 1), StellenArray(k) - 1, 1) = "ß" Then Cells(z, 1) = Left(Cells(z, 1), StellenArray(k) - 1) & " " & Right(Cells(z, 1), Len( _ Cells(z, 1)) - StellenArray(k) + 1) End If End If Next k On Error GoTo 0 x = 0 ReDim StellenArray(x) ' hier auf 0 zurücksetzten, sonst bleiben die Werte des vorherigen _ Treffers stehen Next z End Sub

Beliebteste Forumthreads (12 Monate)

Blank in String einfügen, wenn ...

14
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

299 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Blank in String einfügen, wenn ...

14 Beiträge zum Forumthread Beiträge zu diesem Forumthread

299 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

14
Beiträge zum Forumthread

Beiträge zu diesem Forumthread