anna2701
Aug 19, 2014, updated at 10:16:08 (UTC)
view12627
view8
0
Goto Top

Excel Zelle auf bestimmte Anzahl von Zeichen begrenzen mit VBA

GermansolvedQuestionVB for ApplicationsDevelopment
Hallo zusammen,

ich würde gerne eine Zelle einer Excel Tabelle auf 132 Zeichen begrenzen und der Rest der über bleibt in die Zelle darunter/neben setzen, falls dort dann auch noch mehr als 132 Zeichen sind, wieder darunter/neben. Heißt gerne als schleife, solange die Zeichenanzahl > 132 ist.
Habe schon in verschiedenen Foren geguckt, aber nirgends eine funktionstüchtige Antwort gefunden.

Danke im voraus, Anna! face-smile
comment-contentCommentShareShare
Share on Facebook Share on Twitter Share on Reddit Share on Linkedin

Content-Key: 246825

Url: https://administrator.de/contentid/246825

Printed on: April 19, 2024 at 00:04 o'clock

8 Comments
Latest comment
Goto Top
Member: colinardo
colinardo Aug 19, 2014 updated at 08:17:27 (UTC)
Goto Top
Hallo Anna,
hier ein Beispiel in dem die Zelle A1 im aktiven Tabellenblatt wie gewünscht auf gesplittet wird, und in die nächsten Zeilen darunter verteilt wird.
Sub SplitText()
    dim rngCurrent as Range, intMaxChars as integer
    intMaxChars = 132
    Set rngCurrent = ActiveSheet.Range("A1")  
    ' solange die Zelle in rngCurrent mehr als die angegebene Anzahl an Zeichen enthält ...  
    While Len(rngCurrent.Value) > intMaxChars
        'setze Wert der Zelle unterhalb der aktuellen  
        rngCurrent.Offset(1, 0).Value = Mid(rngCurrent.Value, intMaxChars + 1)
        ' setze Werte der aktuellen Zelle  
        rngCurrent.Value = Left(rngCurrent.Value, intMaxChars)
        'aktuelle Zelle eins nach unten verschieben  
        Set rngCurrent = rngCurrent.Offset(1, 0)
    Wend
End Sub
Grüße Uwe
Member: Anna2701
Anna2701 Aug 19, 2014 at 08:22:32 (UTC)
Goto Top
Danke Uwe, funktioniert super. Hast du vielleicht noch einen Tip, wie ich bei einer vorhandenen Tabelle die Zeile 2 nicht überschreiben lasse sondern unter die benötigten Zeilen einfüge?
Member: colinardo
colinardo Aug 19, 2014 updated at 08:37:36 (UTC)
Goto Top
Zitat von @Anna2701:

Danke Uwe, funktioniert super. Hast du vielleicht noch einen Tip, wie ich bei einer vorhandenen Tabelle die Zeile 2 nicht
überschreiben lasse sondern unter die benötigten Zeilen einfüge?
no problem, Zeile 8 macht hier das gewünschte face-smile
Sub SplitText()
    Dim rngCurrent As Range, intMaxChars As Integer
    intMaxChars = 132
    Set rngCurrent = ActiveSheet.Range("A1")  
    ' solange die Zelle in rngCurrent mehr als die angegebene Anzahl an Zeichen enthält ...  
    While Len(rngCurrent.Value) > intMaxChars
        'Neue Zeile einfügen  
        rngCurrent.Offset(1, 0).EntireRow.Insert
        'setze Wert der Zelle unterhalb der aktuellen  
        rngCurrent.Offset(1, 0).Value = Mid(rngCurrent.Value, intMaxChars + 1)
        ' setze Werte der aktuellen Zelle  
        rngCurrent.Value = Left(rngCurrent.Value, intMaxChars)
        'aktuelle Zelle eins nach unten verschieben  
        Set rngCurrent = rngCurrent.Offset(1, 0)
    Wend
End Sub
Member: Anna2701
Anna2701 Aug 19, 2014 at 09:16:03 (UTC)
Goto Top
Yeeeay Supi. Habe nur noch ein einziges Problem, dann ist es Perfekt :D
Im Moment gilt die Programmierung ja nur für A1 kann ich das erweitern? habe es versucht, ohne Erfolg.
Danke Uwe, du ist echt eine super Hilfe face-smile
Member: colinardo
Solution colinardo Aug 19, 2014 updated at 18:13:31 (UTC)
Goto Top
Zitat von @Anna2701:

Yeeeay Supi. Habe nur noch ein einziges Problem, dann ist es Perfekt :D
Im Moment gilt die Programmierung ja nur für A1 kann ich das erweitern? habe es versucht, ohne Erfolg.
Danke Uwe, du ist echt eine super Hilfe face-smile.
Für deinen geschilderten Fall habe ich mal angenommen das du die Zellen nebenan auch so handhaben willst, in Zeile 4 lässt sich dann der Range angeben. Hierbei wird auch das Einfügen neuer Zeilen in der Schleife beachtet (Zeile 9-11) und nur eine neue eingefügt wenn die nächste Zeile Daten enthält, da es ja sonst zu leeren Spalten kommen würde. Das solltest du für deine Zwecke anpassen können, das Prinzip ist ja damit klar.
Sub SplitTextToLength()
    Dim rngCurrent As Range, intMaxChars As Integer
    intMaxChars = 132
    For Each cell In ActiveSheet.Range("A1:C1")  
        Set rngCurrent = cell
        ' solange die Zelle in rngCurrent mehr als die angegebene Anzahl an Zeichen enthält ...  
        While Len(rngCurrent.Value) > intMaxChars
            'Neue Zeile einfügen nur einfügen wenn die nächste Zeile nicht leer ist  
            If rngCurrent.Offset(1, 0).Value <> "" Then  
                rngCurrent.Offset(1, 0).EntireRow.Insert
            End If
            'setze Wert der Zelle unterhalb der aktuellen  
            rngCurrent.Offset(1, 0).Value = Mid(rngCurrent.Value, intMaxChars + 1)
            ' setze Werte der aktuellen Zelle  
            rngCurrent.Value = Left(rngCurrent.Value, intMaxChars)
            'aktuelle Zelle eins nach unten verschieben  
            Set rngCurrent = rngCurrent.Offset(1, 0)
        Wend
    Next
End Sub
Den Beitrag dann bitte noch auf gelöst setzen. Merci.

Viel Erfolg.
Grüße Uwe
Member: sieglos
sieglos Jan 19, 2015 at 17:09:53 (UTC)
Goto Top
Hallo Uwe,

ich bin nach stundenlanger Suche und Versuchen auf diesen Beitrag gestoßen und hoffe du kannst mir nun weiterhelfen.....mein Problem wurde mit obenstehendem Code schon zu 75% gelöst.

Ich habe eine sehr große Tabelle mit teilweise bis zu 4000 Zeichen in einer Zelle, das Teilen und Zeilen einfügen funktioniert dank dir schon perfekt.

Nur wenn z.B. die Zelle G1 einen langen Text enthält der durch das Makro auf die nächsten beiden Zeilen G2 und G3 aufgeteilt wird, sollen die Zelleninhalte von den Spalten A-F und von H-BN mitkopiert werden da der Filter ansonsten nicht mehr richtig funktioniert.

Vielen Dank für deine/eure Hilfe.

Viele Grüße
Christoph
Member: colinardo
colinardo Jan 20, 2015 at 11:26:28 (UTC)
Goto Top
Hallo Christoph wenn du die letzte Variante des Makros meinst dann lässt sich das so machen:
Sub SplitTextToLength()
    Dim rngCurrent As Range, intMaxChars As Integer
    intMaxChars = 50
    For Each cell In ActiveSheet.Range("G1")  
        Set rngCurrent = cell
        ' solange die Zelle in rngCurrent mehr als die angegebene Anzahl an Zeichen enthält ...  
        While Len(rngCurrent.Value) > intMaxChars
            'Neue Zeile einfügen nur einfügen wenn die nächste Zeile nicht leer ist  
            If rngCurrent.Offset(1, 0).Value <> "" Then  
                rngCurrent.Offset(1, 0).EntireRow.Insert
            End If
            'Daten aus Spalten A-F und H:BN ebenfalls nach unten kopieren  
            Range("A" & rngCurrent.Row & ":BN" & rngCurrent.Row).Copy rngCurrent.Offset(1, 0).EntireRow  
            'setze Wert der Zelle unterhalb der aktuellen  
            rngCurrent.Offset(1, 0).Value = Mid(rngCurrent.Value, intMaxChars + 1)
            ' setze Werte der aktuellen Zelle  
            rngCurrent.Value = Left(rngCurrent.Value, intMaxChars)
            'aktuelle Zelle eins nach unten verschieben  
            Set rngCurrent = rngCurrent.Offset(1, 0)
        Wend
    Next
End Sub
Grüße Uwe
Member: sieglos
sieglos Jan 20, 2015 at 17:05:30 (UTC)
Goto Top
Vielen Vielen Dank !!!

Das Makro spuckt zwar einen Runtime error "13" aus, läuft aber bis Zeile ~15.000 und ich kanns dann einfach in Schritten durchlaufen lassen.

Wäre es zu viel verlangt wenn du mir noch einen Bonus mit einbaust?
Es werden jetzt immer die Wörter bei genau 1000 Zeichen abgeschnitten. Ist es möglich die Zeilen zwischen 900-1000 Zeichen zu "cutten" - immer nach dem letzten Leerzeichen oder nach einem Zeilenumbruch?

Das wär noch der Oberhammer
GermansolvedQuestionVB for ApplicationsDevelopment
Hotly discussed
AlexWishaHow to set up and configure a Linux GRE tunnelAlexWisha - 3 CommentsjstrickerWIREGUARD VPN ON UDM PRO BEHIND FRITZBOX - HANDSHAKE DID NOT COMPLETEjstricker - 1 CommentDaniEnd of Support dates for Office 2016, 2019 Apps und Productivity ServersDani - 1 Comment