Prüfen, ob Text in Zelle passt

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

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

Beliebteste Forumthreads (12 Monate)

14
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

309 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Prüfen, ob Text in Zelle passt

14 Beiträge zum Forumthread Beiträge zu diesem Forumthread

309 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

14
Beiträge zum Forumthread

Beiträge zu diesem Forumthread