Excel Zelle auf bestimmte Anzahl von Zeichen begrenzen mit VBA

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!

Bitte markiere auch die Kommentare, die zur Lösung des Beitrags beigetragen haben

Content-ID: 246825

Url: https://administrator.de/forum/excel-zelle-auf-bestimmte-anzahl-von-zeichen-begrenzen-mit-vba-246825.html

Ausgedruckt am: 23.12.2024 um 09:12 Uhr

8 Kommentare

Neuester Kommentar

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

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?

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

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

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

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

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

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

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

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

gelöst Frage VB for Applications Entwicklung

Mehr von Anna2701

SharePoint 2010 - Freigegebenes Dokument als Anhang in BenachrichtigungAnna2701

VBA mehrere Diagramme auf einem Tabellenblatt erzeugenAnna2701 - 2 Kommentare

Mit VBA prüfen, ob Tabellenblatt existiertAnna2701 - 9 Kommentare

SharePoint 2010 Kommentare lassen sich nicht mehr ausaddieren und verschwinden nach BearbeitungAnna2701

Heiß diskutiert