Text in Spalten bei Länge x ohne Wortabschneiden

Hi,
hoffentlich kann mir jemand mit meinem Problem helfen.
Ich benötige eine Funktionalität, die, falls
1. in einem Zelltext (A1) an jeder Textposition (kleiner/gleich 70), an der ein Absatzzeichen (ALT-Umschlt) existiert, den jeweiligen Resttext (von der Textposition Absatzzeichen+1 an) in eine neue Zelle der Folgereihe (A2) schreibt.
2. in einem Zelltext (A1) an einer Textposition (kleiner/gleich 70) k e i n Absatzzeichen existiert, die Textposition des letzten Leerzeichens vor Textposition 70 wie ein Absatzzeichen behandelt, und den Resttext (von der Textposition LetztesLeerzeichen+1 an) in eine neue Zelle der Folgereihe (A2)schreibt.
Dies jeweils so lange, bis der Resttext zuende ist.
Da ich die Daten anschl. in ein anderes System uploaden will, kann ich die Anforderungen nur unwesentlich ändern.
Gruß
Bärbel

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Bärbel
folgende Lösung schreibt die Texte in den Zellen der Spalte A in ein neues Tabellenblatt und nimmt dabei die gewünschte Aufteilung des Textes vor. Makro starten wenn die Tabelle mit den Texten angezeigt wird.
Ich hoffe das hilft weiter.
gruss
Franz


Sub TextAufteilen()
Dim wksOriginal As Worksheet, wksNeu As Worksheet, strText As String, strNeu As String
Dim iZeile As Long, iZeileN As Long, iZeichen1 As Integer, Zeichen2 As Integer
Set wksOriginal = ActiveSheet
ActiveWorkbook.Worksheets.Add after:=wksOriginal, Type:=xlWorksheet
Set wksNeu = ActiveSheet
wksNeu.Name = "TextNeu"
With wksOriginal
iZeileN = 1
For iZeile = 1 To .Cells(.Rows.Count, "A").End(xlUp).Row
strText = .Cells(iZeile, "A")
iZeichen2 = 1
strNeu = ""
For I = 1 To Len(strText)
iZeichen1 = I
Do
strNeu = strNeu & Mid(strText, I, 1)
iZeichen2 = I
If I = Len(strText) Then Exit Do
I = I + 1
Loop Until Mid(strText, I, 1) = Chr$(10) Or iZeichen2 - iZeichen1 = 68
If Mid(strText, I, 1) = Chr$(10) Or I = Len(strText) Then
wksNeu.Cells(iZeileN, 1) = strNeu
Else
If Mid(strText, I + 1, 1) = " " Or Mid(strText, I + 1, 1) = Chr$(10) Then
wksNeu.Cells(iZeileN, 1) = strNeu & Mid(strText, I, 1)
I = I + 1
Else
Do
I = I - 1
strNeu = Left(strNeu, Len(strNeu) - 1)
Loop Until Right(strNeu, 1) = " "
I = I - 1
wksNeu.Cells(iZeileN, 1) = Left(strNeu, Len(strNeu))
End If
End If
iZeileN = iZeileN + 1
strNeu = ""
Next I
Next iZeile
End With
End Sub

Option Explicit Sub UmbruchVerteil() Dim maxL As Integer, wsQ As Worksheet, zQ As Long, strT As String, arr Dim nn As Integer, ii As Integer, zZ As Long, pp As Integer maxL = 70 ' maximale Textlänge Sheets("Tabelle1").Select ' Quellblatt maxL = maxL + 1 Set wsQ = ActiveSheet ' neues Blatt (evtl. vorher löschen) Application.DisplayAlerts = False On Error Resume Next Sheets("TextNeu2").Delete On Error GoTo 0 Application.DisplayAlerts = True ActiveWorkbook.Worksheets.Add(after:=wsQ).Name = "TextNeu2" ' Bearbeitung For zQ = 1 To wsQ.Cells(Rows.Count, 1).End(xlUp).Row strT = wsQ.Cells(zQ, 1) ' Zerlegung bei Umbrüchen arr = Split(strT, Chr(10)) nn = UBound(arr) For ii = 0 To nn If Len(arr(ii)) < maxL Then zZ = zZ + 1 Cells(zZ, 1) = RTrim(arr(ii)) Else ' Zerlegung bei Leerzeichen/Überschreitung While Len(arr(ii)) > 70 pp = InStrRev(Left(arr(ii), maxL), " ") If pp <= 1 Then pp = maxL zZ = zZ + 1 Cells(zZ, 1) = RTrim(Left(arr(ii), pp - 1)) arr(ii) = RTrim(Right(arr(ii), Len(arr(ii)) - pp - (pp = maxL))) Wend If Len(arr(ii)) > 0 Then zZ = zZ + 1 Cells(zZ, 1) = RTrim(arr(ii)) End If End If Next ii Next zQ Columns(1).AutoFit End Sub

Beliebteste Forumthreads (12 Monate)

Text in Spalten bei Länge x ohne Wortabschneiden

4
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

316 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Text in Spalten bei Länge x ohne Wortabschneiden

4 Beiträge zum Forumthread Beiträge zu diesem Forumthread

316 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

4
Beiträge zum Forumthread

Beiträge zu diesem Forumthread