[VBA?] Nach Texteingabe Zellen aufteilen

[Suphi]

Hallo,

meine aktive Zelle ist auf 42 Zeichen begrenzt und soll bei längeren Texte bei aktivierten Zeilenumbruch
denn Textinhallt auf max. 4 folgenden Zellen aufteilen.
Hab schon überall nach einer Lösung gesucht aber nix mit aufteilen bei Texteingabe finden können.
Würde mich freuen wenn jemand mir hier weiterhelfen könnte..

Danke

Suphi

[Castor]

Hallo, Suphi;
dazu wirst du auch nichts finden, denn das ist keine Xl-Standard-Funktionalität. Auch das Aufteilen mit Text-in-Spalten funktioniert kaum, da du ja, wohl in der Nähe der Maximallänge pro Zelle (sinnvoll) teilen willst. Das geht nur im Nachhinein und mit VBA bzw VBA-gestützten selbstdefinierten Funktionen (UDFs) in einer Zellformel.
Unter diesem Link kannst du eine Datei runterladen, die u.a. die beiden UDFs TxRows und Splitt enthält, mit denen das in einer Zellformel bewerkstelligt werden kann:
{=Splitt(TxRows(A1;42);Zeichen(10))}
Dabei wird an der letzten sinnvollen Stelle vor der Maximallänge ein Zeilenumbruch eingefügt. Da du ja den Text auf verschiedene Spalten (alle mit max 42 Zeichen Text!) aufteilen willst, musst du zusätzlich Splitt verwenden, das den Text beim Zeilenumbruch teilt. Durch Eingabe der Formel als Matrixformel (durch die nicht miteinzugebenden {} gekennzeichnet) bei vorheriger Auswahl der benötigten Zellen, wird der Text sinnvoll aufgeteilt.
Ist das nicht deine Absicht und der Text soll stets in 42-Zeichen-lange Teilstücke geteilt werden, käme folgende Formel zum Einsatz:
=TEIL($A1;(SPALTE(A1)-1)*42+1;42)
Die kann dann über die benötigten Spalten gezogen werden.
Gruß, Castor

[Suphi]

@Castor: Komme mit deiner Anleitung nicht ganz klar, ich will keine Textausgabe aufteillen sondern die Aktuelle Eingabe.

hab diesen VBA Code gefunden,Funktioniert auch soweit ganz gut nur will ich nicht dass er mit das Wort nach 42 Zeichen
in Zwei Teilt. Gibs es eine Funktion wie bei Zeilenumbruch wo das Wort nicht getrennt wird ?

Code:

Private Sub Worksheet_Change(ByVal Target As Range)
   On Error GoTo ERR_HANDLER
   Dim AktiveZeile As Integer
   Dim AktiveSpalte As String * 1
   Dim Zeichenzahl As Integer
   Dim Text As String * 210
   
   AktiveZeile = Target.Row
   AktiveSpalte = "B"
   Zeichenzahl = Len(Range(AktiveSpalte & (AktiveZeile)).Value)
   Text = Range(AktiveSpalte & (AktiveZeile)).Value
       
   If Zeichenzahl > 42 Then
       Range(AktiveSpalte & (AktiveZeile + 1)) = Mid(Text, 41)
       Range(AktiveSpalte & AktiveZeile) = Left(Text, 40)
   End If
   
ERR_HANDLER:

End Sub

gruss

Suphi

[schauan]

Hallo Suphi,

wo soll denn getrennt werden, wenn ein Wort die Grenze überschreitet? Ich nehme an, am letzten Leerzeichen vor dem 42. Zeichen?

Du könntest z.B. in einer Schleife die Stellen der Leerzeichen des Textes ermitteln und dann entsprechend schneiden.
Oder Du splittest den Text an den Leerzeichen und setzt ihn dann wieder zusammen:

im Prinzip so:

strTemp=Split(Text, " ")
for i=lbound(strtemp) to ubound(strTemp)
if len(strText) + len(strTemp(i)) < 42 then strText=strText & " " & strTemp(i)
Next

Das wäre jetzt nur die erste Zeile, musst also noch etwas dran schrauben.

[Castor]

Was du da eingestellt hast, Suphi,
ist eine Ereignisprozedur. Die reagiert auch nicht während der Eingabe, sondern erst nach deren Abschluss. Statt nun ein komplettes Programm in diese Prozedur zu stecken, solltest du sie als Verteiler benutzen, denn du hast nur eine _Change-Prozedur pro Blatt, eine pro Mappe und eine für Xl insgesamt.
Statt eines Verteilers kannst du im Relevanzfall auch mit Funktionsaufrufen arbeiten:

Code:

Const maxTTxtLg As Long = 42
Dim zwErg As Variant
...
If Len(Target) > maxTTxtLg Then
    zwErg = Split(TxRows(Target, maxTTxtLg), vbLf)
    Target.Resize(1, UBound(zwErg) + 1) = zwErg
End If
...

Die UDF TxRows reagiert übrigens nicht nur auf Leer-, sondern noch eine Reihe anderer Satzzeichen. Der Originaltext wird hier überschrieben.
Übrigens, nicht das zeitweilige Sperren von Ereignisreaktionen (Application.EnableEvents = False/True bei Eintreten des Relevanzfalles (und nach Abschluss) vergessen, sonst ruft sich die Prozedur endlos selbst auf, da diese Aktion selbstverständlich ebenfalls eine Änderung ist.
Gruß, Castor

[Suphi]

@ Castor : bekomme immer sub oder function nicht definiert fehler meldung angezeigt,was mache ich falsch !?

Code:

Private Sub Worksheet_Change(ByVal Target As Range)

  On Error GoTo ERR_HANDLER
  Const maxTTxtLg As Long = 42
  Dim zwErg As Variant

If Len(Target) > maxTTxtLg Then
   zwErg = Split(TxRows(Target, maxTTxtLg), vbLf)
   Target.Resize(1, UBound(zwErg) + 1) = zwErg
End If
 
ERR_HANDLER:

End Sub

@schauan: kenne mich mit VBA so gut wie null aus weiss nicht wie ich dein Code vervollständingen soll ?  

gruss

Suphi

[Castor]

Du hast meinen Hinweis auf Application.EnableEvents = False bzw True nicht beachtet, Suphi,
und insofern Glück gehabt, dass du offensichtlich vergessen hast dem Link in meiner 1.Antwort zu folgen und den ProgrammCode der UDF TxRows in dein VBA-Projekt zu übernehmen.
Sich mit VBA nicht auszukennen ist keine Entschuldigung für jemanden, der VBA anwenden will, nur sträflicher Leichtsinn, besonders bei Ereignisprozeduren. :-|

Code:

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    Const maxTTxtLg As Long = 42, adRelBer$ = "A1:A10" '<-- anpassen!
    Dim zwErg As Variant
    If Not Intersect(Target, Me.Range(adRelBer)) Is Nothing Then
        If Len(Target) > maxTTxtLg Then
            With Application
                .EnableEvents = False
                zwErg = Split(TxRows(Target, maxTTxtLg), vbLf)
                Target.Resize(1, UBound(zwErg) + 1) = zwErg
                .EnableEvents = True
            End With
        End If
    End If
End Sub

Die Ereignisprozedur muss im Dokument-Klassenmodul der jeweiligen Tabelle des VBA-Projekts deiner Datei angelegt werden. Die UDF muss in ein extra anzulegendes (allgemeines, nicht Klassen-)Modul des Projektes kopiert werden, falls du sie im ganzen Projekt (evtl auch in Zellformeln) benutzen willst. Ansonsten könnte sie auch ins gleiche Modul wie die obenstehende Ereignisprozedur.
Castor

[Suphi]

danke funktioniert jetzt wie es soll :)

gruss

Suphi