Langtext nach Zeichenlänge aufsplitten

[Marler]

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 ...

[steve1da]

Hola,

zur Info:

http://www.office-loesung.de/p/viewtopic.php?f=166&t=737884

Gruß,
steve1da

[Marler]

Hola,

zur Info:

http://www.office-loesung.de/p/viewtopic.php?f=166&t=737884

Gruß,
steve1da

Danke, siehe oben. 

[GMG-CC]

[Gelöscht ...]

[Gast 123]

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

[Castor]

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

[Marler]

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

[WillWissen]

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.

[atilla]

Hallo,

schau mal ob das passt:

Code:

Sub mach()
Dim i As Long, j As Long, k As Long
Dim strgT As String, strgTeil As String
Dim varStrg

j = 4 'ab spalte 4 nach rechts

Application.ScreenUpdating = False
For k = 3 To 200    'Texte ab Zeile 3 in spalte A bis Zeile 200
 If Cells(k, 1) <> "" Then 'die 1 steht hier für Spalte A
   i = 0
   j = 4
   strgT = Cells(k, 1)
   varStrg = Split(strgT)
   Do
     Do
       If Len(strgTeil & varStrg(i) & " ") > 80 Then Exit Do
       strgTeil = strgTeil & varStrg(i) & " "
       i = i + 1
     Loop Until i = UBound(varStrg) + 1
     If i < UBound(varStrg) Then
       Cells(k, j) = (strgTeil)
     Else
       Cells(k, j) = RTrim(strgTeil)
     End If
     j = j + 1
     strgTeil = ""
   Loop Until i = UBound(varStrg) + 1
 End If
Next k
Application.ScreenUpdating = True
End Sub

[Marler]

Danke attila,

das ist es! Vielen herzlichen Dank, du hast mir sehr geholfen.   :23:

viele Grüße

Marler