Prüfen, ob Text in Zelle passt

Jürgen Schaetzke · 2004-02-08T16:28:13+00:00

Hallo, ich habe einen Kalender aufgebaut, der Veranstaltungen und Feiertage anzeigen soll. Wenn die Zellbreite nicht ausreicht,möchte ich die Ausgabezelle mit danebenliegende Zellen verknüpfen. Gibt es dazu eine Möglichkeit zu prüfen, ob der Text in die Zelle passt? Da die Zeichen unterschiedliche Breite haben und auch Fettschrift und Schriftgröße eine Rolle spielen, kann ich nicht die Anzahl der Buchstaben für die Prüfung verwenden. Mit freundlichen Grüßen Jürgen Schaetzke

Hallo Jürgen,
probiere es mal mit folgenen Makro. Über einen "dirty" Trick wird der Text erstmal getestet und wenn zu lang, dann werden die entsprechenden Zellen verbunden:


Public Sub ZellBreite()
Dim rng     As Range
Dim cnt     As Integer
'Text in eine Zelle schreiben, die nicht benötigt wird
With ActiveSheet.Range("AN60000")
'Startzelle A1 für Text
Set rng = ActiveSheet.Range("A1")
'Text zum Testen
.Value = "Telefontarifauskunft von der Quantum Software GmbH"
.Columns.AutoFit
If rng.Width < .Width Then
cnt = .Width / rng.Width
'Zellen ab Startzelle A1 bis A(cnt) verbinden
ActiveSheet.Range(ActiveSheet.Cells(1, 1), ActiveSheet.Cells(1, cnt)).Merge
End If
'Text in Zelle A1 schreiben
rng.Value = .Value
End With
End Sub

Hallo Jürgen
wie K.Rola auch schon bemerkte, dürfte das ganze nicht funktionieren wenn Text in den benachbarten Spalten steht, und es werden unterschiedliche Spaltenbreiten nicht berücksichtigt.
Deshalb hier etwas modifiziert:

Public Sub ZellBreite()
'von Alex K aus Herber.de
'Prüft ob ein Textstring in eine Zelle passt
'wenn nicht, werden automatisch entsprechend Zellen gemergt
'Modified by Ramses
'Prüfung auf unterschiedliche Spaltenbreite
'Prüfung ob Text vorhanden
Dim rng     As Range
Dim n As Integer
Dim tmpWidth As Double
'Text in eine Zelle schreiben, die nicht benötigt wird
With ActiveSheet.Range("IV1")
    'Startzelle A1 für Text
    Set rng = ActiveSheet.Range("A1")
    'Text zum Testen
    .Value = "Telefontarifauskunft von der Quantum Software GmbH"
    'Automatisch die Breite anpassen lassen
    .Columns.AutoFit
    'Prüfung ob die Breite in Spalte A kleiner ist als
    'die automatisch angepasste Breite in IV1
    If rng.Width < .Width Then
        tmpWidth = 0
        n = 0
        Do Until tmpWidth > .Width
            'Prüfung ob benötigte Spalte leer ist
            If rng.Offset(0, n) <> "" Then
                MsgBox "Text kann nicht eingefügt werden" & vbCrLf & _
                    "weil in Spalte " & Columns(n + 1).Address & " Text vorhanden ist," & vbCrLf & _
                    "der für das Mergen benötigt wird"
                    Exit Sub
            End If
            tmpWidth = tmpWidth + rng.Offset(0, n).Width
            n = n + 1
        Loop
        'Zellen ab Startzelle A1 bis A(n) verbinden
        ActiveSheet.Range(ActiveSheet.Cells(1, 1), ActiveSheet.Cells(1, n)).Merge
    End If
    'Text in Zelle A1 schreiben
    rng.Value = .Value
End With
End Sub

Code eingefügt mit Syntaxhighlighter 2.5

Trotzdem,.... den Trick hat Alex rausbekommen :-))
Gruss Rainer

Forumthread: Prüfen, ob Text in Zelle passt

14
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Forumthreads zu verwandten Themen

Infobox / Tutorial

Text in Zelle prüfen: So geht's in Excel

Schritt-für-Schritt-Anleitung

Häufige Fehler und Lösungen

Alternative Methoden

Praktische Beispiele

Tipps für Profis

FAQ: Häufige Fragen

Beliebteste Forumthreads (12 Monate)