Hallo liebe Excelprofis,
ich habe momentan eine Herausforderung, die ich mit meinem Wissen nicht lösen kann.
Ich habe in Excel 2013 einen Langtext mit mehr als 1000 Zeichen und möchte diesen gern auf die Nebenspalten mit einer Zeichenlänge von jeweils 100 Zeichen aufteilen, aber so dass kein Wort geteilt wird. Mit der Funktion TEIL bekomme ich es hin, aber ich will ja keine Wörter trennen.
Ich habe mich schon "totgesucht" aber nichts Brauchbares gefunden (außer
http://www.herber.de/excelformeln und bitte suchen .../formeln.html?welcher=383 , wo ich die Textzeilen jedoch nicht in die Spalten daneben bekomme) oder ich stelle mich zu blöd an.
Kann mir geholfen werden?
Vorab schon einmal vielen Dank
Marler
P.S. Irgendwie habe ich diese Frage (warum auch immer) in einem anderem Forum gepostet ...
Hallo Marler,
unabhaengig das andere Lösungen vorliegen hatte ich mir bereits die Arbeit gemacht und drei Makros geschrieben. Zu schade für den Mülleimer!!
Zwei Makros zum Testen einen String nach Unten oder nach Rechts zerlegen. Das 3. Makro um einen ganzen Text-Bereich nach Rechts zu zerlegen.
Oben in Const must du deinen Adress Bereich angeben, zum Testen "C7:C8" Die Wortlaenge steht auf wl=40, kann beliebig erhöht werden.
mfg Gast 123
Code:
Option Explicit '24.6.2017 Gast 123 Clever Forum
Const TextRange = "C7:C8" 'Text-Bereich festlegen
Const wl = 40 'Anzahl der Wortlaenge festlegen
Dim Txt As String, AC As Range
Dim Strg As String, j As Integer
'zerlegt Text von Aktiver Zelle nach Unten
Sub Test_String_nachUnten_zerlegen()
Strg = ActiveCell.Value
'String anch unten zerlegen
For j = 1 To 30
a = InStr(wl, Strg, " "): c = a
b = InStrRev(Strg, " ", wl)
If wl - b < a - wl Then c = b
'Text nach Wortlaenge abschneiden
Txt = Left(Strg, c - 1) '0 mit " "
Strg = Right(Strg, Len(Strg) - c)
ActiveCell.Offset(j, 0) = Txt
If Len(Strg) <= wl Then
ActiveCell.Offset(j + 1, 0) = RTrim(Strg)
Exit For
End If
Next j
End Sub
'zerlegt Text von Aktiver Zelle nach Rechts
Sub Test_String_nachRechts_zerlegen()
Strg = ActiveCell.Value
'String anch Rechts zerlegen
For j = 1 To 30
a = InStr(wl, Strg, " "): c = a
b = InStrRev(Strg, " ", wl)
If wl - b < a - wl Then c = b
'Text nach Wortlaenge abschneiden
Txt = Left(Strg, c - 1) '0 mit " "
Strg = Right(Strg, Len(Strg) - c)
ActiveCell.Offset(0, j) = Txt
If Len(Strg) <= wl Then
ActiveCell.Offset(0, j + 1) = RTrim(Strg)
Exit For
End If
Next j
End Sub
'zerlegt Text-Bereich nach Rechts
Sub TextBereich_nachRechts_zerlegen()
Dim a As Integer, b As Integer, c As Integer
'Adress Bereich in Const angeben !!
For Each AC In Range(TextRange)
Strg = AC.Value & " "
'String anch Rechts zerlegen
For j = 1 To 30
a = InStr(wl, Strg, " "): c = a
b = InStrRev(Strg, " ", wl)
If wl - b < a - wl Then c = b
'Text nach Wortlaenge abschneiden
Txt = Left(Strg, c - 1) '0 mit " "
Strg = Right(Strg, Len(Strg) - c)
AC.Offset(0, j) = Txt
If Len(Strg) <= wl Then
AC.Offset(0, j + 1) = RTrim(Strg)
Exit For
End If
Next j
Next AC
End Sub
Zu schade für den Mülleimer - mag sein, 123.Gast,
aber im OL-Forum sind auch (noch) Lösungen gekommen, die immer wieder für Ähnliches, auch für Teil- und weiterführende Aufgaben daraus, einsetzbar sind → auch in Zellformeln!
Die sollte sich Marler durchaus auch mal ansehen und dort ebenfalls Feedback geben! ;-]
Gruß, Castor
(24.06.2017, 19:16)Gast 123 schrieb: [ -> ]Hallo Marler,
unabhaengig das andere Lösungen vorliegen hatte ich mir bereits die Arbeit gemacht und drei Makros geschrieben. Zu schade für den Mülleimer!!
Zwei Makros zum Testen einen String nach Unten oder nach Rechts zerlegen. Das 3. Makro um einen ganzen Text-Bereich nach Rechts zu zerlegen.
Oben in Const must du deinen Adress Bereich angeben, zum Testen "C7:C8" Die Wortlaenge steht auf wl=40, kann beliebig erhöht werden.
mfg Gast 123
Code:
Option Explicit '24.6.2017 Gast 123 Clever Forum
Const TextRange = "C7:C8" 'Text-Bereich festlegen
Const wl = 40 'Anzahl der Wortlaenge festlegen
Dim Txt As String, AC As Range
Dim Strg As String, j As Integer
'zerlegt Text von Aktiver Zelle nach Unten
Sub Test_String_nachUnten_zerlegen()
Strg = ActiveCell.Value
'String anch unten zerlegen
For j = 1 To 30
a = InStr(wl, Strg, " "): c = a
b = InStrRev(Strg, " ", wl)
If wl - b < a - wl Then c = b
'Text nach Wortlaenge abschneiden
Txt = Left(Strg, c - 1) '0 mit " "
Strg = Right(Strg, Len(Strg) - c)
ActiveCell.Offset(j, 0) = Txt
If Len(Strg) <= wl Then
ActiveCell.Offset(j + 1, 0) = RTrim(Strg)
Exit For
End If
Next j
End Sub
'zerlegt Text von Aktiver Zelle nach Rechts
Sub Test_String_nachRechts_zerlegen()
Strg = ActiveCell.Value
'String anch Rechts zerlegen
For j = 1 To 30
a = InStr(wl, Strg, " "): c = a
b = InStrRev(Strg, " ", wl)
If wl - b < a - wl Then c = b
'Text nach Wortlaenge abschneiden
Txt = Left(Strg, c - 1) '0 mit " "
Strg = Right(Strg, Len(Strg) - c)
ActiveCell.Offset(0, j) = Txt
If Len(Strg) <= wl Then
ActiveCell.Offset(0, j + 1) = RTrim(Strg)
Exit For
End If
Next j
End Sub
'zerlegt Text-Bereich nach Rechts
Sub TextBereich_nachRechts_zerlegen()
Dim a As Integer, b As Integer, c As Integer
'Adress Bereich in Const angeben !!
For Each AC In Range(TextRange)
Strg = AC.Value & " "
'String anch Rechts zerlegen
For j = 1 To 30
a = InStr(wl, Strg, " "): c = a
b = InStrRev(Strg, " ", wl)
If wl - b < a - wl Then c = b
'Text nach Wortlaenge abschneiden
Txt = Left(Strg, c - 1) '0 mit " "
Strg = Right(Strg, Len(Strg) - c)
AC.Offset(0, j) = Txt
If Len(Strg) <= wl Then
AC.Offset(0, j + 1) = RTrim(Strg)
Exit For
End If
Next j
Next AC
End Sub
Vielen Dank, habe es ausprobiert und es funktioniert - doch leider immer nur bei einzelnen Texten. Das Makro wird leider immer nur bei einer einzelnen Zelle angewandt, oder es liegt (wie so meist) am User vor dem Bildschirm.
Meine Herausforderung ist, dass ich von solch langen Texten Hunderte habe.
viele Grüße
Marler
Hallo Marler,
du musst nicht immer den gesamten Beitrag zitieren. Benutze bitte den Antwort-"Button" unterhalb des Antwortformulars oder ganz oben rechts. Notwendige Zitiate kannst du herauskopieren und durch Klick auf den 3. Icon von rechts in das Feld einfügen.
Danke attila,
das ist es! Vielen herzlichen Dank, du hast mir sehr geholfen. :23:
viele Grüße
Marler
