AW: Zeilenhöhe von Zellen/verbundenen Zellen
07.11.2008 10:34:00
Zellen/verbundenen
Hallo Christian,
super dass mein Vorschlag etwa deinen Anforderungen gerecht wird.
Problem manuelle Zeilenwechsel:
Wenn in praktisch jeder Zeile ein Zeilenwechsel eingefügt ist, dann funktioniert die Ermittlung der erforderlichen Zeilenhöhen auch recht gut. Sie wird dann ungenau, wenn der Text sehr ungleichmäßig auf die Zeilen verteilt ist, z.B. 1. Texthälfte enthält viel Text je Zeile, 2. Texthälfte wenig Text je Zeile.
Ich hab die Haupt-Prozedur noch ein wenig optimiert, so dass die Variationen in Textlängen und Zeilenwechsel besser berücksichtigt werden.
Gruß
Franz
Sub VerbindenVertikal(ZielZelle As Range)
'Bei zuviel Text in Zelle werden Leerzeile(n) eingefügt und Zellen vertikal verbunden.
Dim lngZeile As Long, lngZeile2 As Long, Spalte As Long
Dim strInhalt As String, strTeil As String, strRest As String, Zelle As Range
Dim lngCount As Long, lngCount2 As Long, lngI As Long
Dim dblZeilenhoehe As Double, dblTeilHoehe As Double
Dim arrHoehen() As Double
If ZielZelle.WrapText = False Then
MsgBox "Zelle muss mit Textausrichtung ""Zeilenumbruch"" formatiert sein, " _
& "damit Makro funktioniert!"
Exit Sub
End If
Application.ScreenUpdating = False
lngZeile = ZielZelle.Row 'Zeile der Zelle die Text enthält
Spalte = ZielZelle.Column 'Spalte der Zelle die Text enthält
If ZielZelle.MergeCells = True Then
'letzte zeile der verbundenen Zellen
lngZeile2 = lngZeile + ZielZelle.MergeArea.Rows.Count - 1
'Verbindung der Zellen aufheben
ZielZelle.MergeArea.UnMerge
'Zeilen der verbundenen unterhalb der 1. Zeile löschen
Range(Rows(lngZeile + 1), Rows(lngZeile2)).Delete shift:=xlShiftUp
End If
'Optimale Höhe der Zeile einstellen
Rows(lngZeile).AutoFit
If Rows(lngZeile).RowHeight > 409 Then
Set Zelle = Cells(lngZeile, Spalte) 'Zelle mit Textinhalt
'Inhalt der Zelle merken
strInhalt = Zelle.Value
Zelle.ClearContents
dblZeilenhoehe = Rows(Zelle.Row).RowHeight 'Mindestzeilenhöhe für 1. Zeile merken
'Leerzeile unter Text einfügen
Rows(Zelle.Row + 1).Insert shift:=xlShiftDown
lngCount = 0
'erforderliche Höhe der verbundenen Zeilen ermitteln durch Einfügen von Teiltexten
' in Leerzeile
strRest = strInhalt
Do
lngCount = lngCount + 1
ReDim Preserve arrHoehen(1 To lngCount)
lngCount2 = 0
strRest = Mid(strRest, Len(strTeil) + 1)
strTeil = strRest
Do
Zelle.Offset(1, 0).Value = strTeil
dblTeilHoehe = Rows(Zelle.Row + 1).RowHeight
If dblTeilHoehe 2 Then
'ggf. weitere LeerZeilen einfügen
For lngI = 3 To lngCount
Rows(Zelle.Row + 1).Insert shift:=xlShiftDown
Next
End If
'Inhalt wieder in Zelle einfügen
Zelle.Value = strInhalt
'Zeilenhöhen festlegen
For lngI = 1 To lngCount
Rows(Zelle.Row + lngI - 1).RowHeight = arrHoehen(lngI)
Next
'Zellen vertikal verbinden
Range(Zelle, Zelle.Offset(lngCount - 1, 0)).Merge
End If
Application.ScreenUpdating = True
End Sub