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
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
Hallo Gast 123,
ich bedanke mich vielmals.
Das ist perfekt.
Wunderbar.
Allerherzlichsten Dank.
Liebe Grüße
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?
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
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