nach Anzahl X Zeichen -> nächste Zelle

[Klaus]

Hallo miteinander,

ich möchte via Userform den Inhalt einer Textbox an eine Zelle übergeben. AY22.

Ist es möglich, dass nach 50 Zeichen (Zahlen und Buchstaben gemischt) der Text in der darunter liegenden Zelle und dann der darunter liegenden usw (aber max 4 Zellen untereinander) eingefügt wird?
Allerdings jeweils so, dass die Wörter nicht abgeschnitten werden? 

Vielen Dank schon im Voraus.
Liebe Grüße
Klaus

[Gast 123]

Hallo

es gibt ein kleines aber sicher sehr nützliches Universal Makro dazu. Bitte mal testen wie gut es funktioniert.

Seine Besonderheit sind die drei Const Anweisungen, wo man vorgeben kann wie lang der Text sein soll. Die Auswertung wo abgeschnitten werden soll erfolgt über einen Vor- und Rückwaerts Zaehler, die einstellbar sind. Akzeptiert werden Textlaengen bis max. 55 Zeichen, oder ein Text zwischen 40-50 Zeichen. Zum Code testen habe ich den Text aus der Anfrage genommen. Schau dir das Ergebnis bitte mal an. Die Laenge kannst du selbst optimieren.

mfg Gast 123

Code:

Option Explicit   '2.11.2019   Gast 123   Clever Forum
Const zVw = 40    'Vorwaerts Zaehler ab 40 Zeichen
Const zRw = 55    'Rückwaerts Zaehler ab 55 Zeichen
Const zMw = 50    'Mittelwert 50 Zeichen zum Trennen


'Makro zum Text in vier Yeile zerlegen

Sub String_zerlegen()
Dim Txt1, Txt2, Txt3, Txt4
Dim CTxt1, CTxt2, Strg, i As Integer
  'Strg = UserForm1.Textbox1
   Strg = "Ist es möglich, dass nach 50 Zeichen (Zahlen und Buchstaben gemischt) der Text in der darunter liegenden Zelle und dann der darunter liegenden usw (aber max 4 Zellen untereinander) eingefügt wird?"

  'Schleife zum String ib 4 Teile zerlegen
  For i = 1 To 3
     'Test ab 40 Zeichen vorwaerts, ab 55 Rückwaerts
     CTxt1 = Left(Strg, InStr(zVw, Strg, " "))
     CTxt2 = Left(Strg, InStrRev(Strg, " ", zRw))
     
     'auswerten wo abgeschnitten werden soll
     If zMw - Len(CTxt1) < zRw - Len(CTxt2) Then
        If i = 1 Then Txt1 = CTxt1
        If i = 2 Then Txt2 = CTxt1
        If i = 3 Then Txt3 = CTxt1
        Strg = Right(Strg, Len(Strg) - Len(CTxt1))
     Else
        If i = 1 Then Txt1 = CTxt2
        If i = 2 Then Txt2 = CTxt2
        If i = 3 Then Txt3 = CTxt2
        Strg = Right(Strg, Len(Strg) - Len(CTxt2))
     End If
       
     'Teilstring in Variable übernehmen
     If i = 3 Or Len(Strg) < 50 Then
        If i = 3 And Txt3 <> "" Then Txt4 = Strg
        If i = 2 And Txt2 <> "" Then Txt3 = Strg
        If i = 1 And Txt1 <> "" Then Txt2 = Strg
        If Len(Strg) = 0 Then Exit For
     End If
  Next i
     
  '** bei Trim(Txt) ohne Space am Ende
  Range("AY22").Value = Txt1  '45  Trim(Txt1)
  Range("AY23").Value = Txt2  '50
  Range("AY24").Value = Txt3  '48
  Range("AY25").Value = Txt4  '53

End Sub

[Klaus]

Hallo Gast 123,

ich bedanke mich vielmals. 
Das ist perfekt.
Wunderbar.

Allerherzlichsten Dank.

Liebe Grüße
Klaus

[Klaus]

ohaaa... ich muss doch nochmal nachhaken...

Bei langen Texten und langen Wörtern funktioniert das.

Schreibt man nun einen kurzen Text in das Textfeld, dann wird der Text garnicht angezeigt.
Endet der lange Text mit kurzen Worten werden auch diese nicht angezeigt.

Irgendwo hängt der Wurm drin.

Hiiiilfeee... was kann ich tun?

[Kuwer]

Hallo Klaus,

teste mal damit:

Option Explicit

Sub TextSplittenKuwer()
  Dim lngZ As Long, lngPos As Long
  Dim strText As String
  Dim varText(1 To 4, 1 To 1)
  
  strText = "Ist es möglich, dass nach 50 Zeichen (Zahlen und Buchstaben gemischt) der Text in der darunter liegenden Zelle und dann der darunter liegenden usw (aber max 4 Zellen untereinander) eingefügt wird?"
  strText = InputBox("")
  On Error Resume Next
  For lngZ = 1 To 3
    lngPos = InStrRev(strText, " ", 51)
    If lngPos = 0 Then lngPos = 50
    varText(lngZ, 1) = Left(strText, lngPos - 1)
    strText = Mid(strText, lngPos + 1)
  Next lngZ
  varText(lngZ, 1) = strText
  Range("AY22").Resize(4).Value = varText
  On Error GoTo 0
End Sub

Gruß Uwe

[Klaus]

Guten Morgen Uwe,

jaaa... so isses Klasse. Einzelne Wörter lassen sich ebenso wie lange Texte schreiben. 

Wunderbar  :100:
Herzlichen Dank

Liebe Grüße
Klaus