AW: Automatische Zellenhöhe bei verbunden Zellen
20.01.2008 12:29:00
Paul
Hallo Daniel,
vielen Dank für deine Unterstützung. Jetzt wendet er den Schritt bei allen verbundenen Zellen an, aber nicht mehr in D13. Was habe ich falsch gemacht? Hier mein neuer Code:
Private Sub Worksheet_Change(ByVal Target As Excel.Range)
' Unter Verwendung von Excel-Beispiel Nr.137101,
' "Zeilenhöhe bei verbundenen Zellen anpassen"
' von Hans W. Herber, 53567 Asbach,
' erweitert und individuell angepasst von Volker Croll
' September 2004 © CrollTools
' Postfach 1332, 71656 Vaihingen
' Tel: 0 70 42 / 8 19 88 27
' Fax: 0 70 42 / 8 19 88 28
' www.crolltools.de
Dim CurrentRowHeight As Single, MergedCellRgWidth As Single
Dim CurrCell As Range
Dim ActiveCellWidth As Single, PossNewRowHeight As Single
Dim iX As Integer
' Target.Address wird bei verbundenen Zellen von den verschiedenen Excel-Versionen
' unterschiedlich ausgegeben, deshalb eine Or-Bedingung:
If Target(1).Interior.ColorIndex = 36 Then
' damit der Cursor - unabhaengig von den Excel-Grundeinstelungen - nach Druecken der
' ENTER-Taste in die Zelle D14 springt (Berechnung von Hans setzt dies voraus!):
Target(1).Offset(1, 0).Select
If Target(1).MergeCells Then
' Bei sehr langen Text berechnet Excel (auch bei nicht verbundenen Zellen!) die
' optimale Zeilehoehe (AutoFit) nicht mehr richtig, deshalb Pruefung der Textlaenge:
If Len(Target(1)) > 1000 Then
MsgBox "Der von Ihnen eingegebene Text umfasst mehr als 1000 Zeichen !" & Chr( _
10) & _
"Bitte kürzen Sie ihn entsprechend !", 48, "Text zu lang !"
' direkte Rueckkehr zur falsch ausgefuellten Zelle. Damit der User aber nicht
' komplett neu eingeben muss, wird der zulange Text trotzdem nicht geloescht:
Target(1).Select
Exit Sub
End If
Application.ScreenUpdating = False
' Die Zeilenhoehe ist von Excel begrenzt auf 409. Durch eine Veraenderung der
' Schriftgroesse koennte diese Grenze ueberschritten werden. Ausserdem wuerde der
' Ausdruck dann nicht mehr auf eine Seite passen. Somit wird die Schriftgroesse
' wieder zurueckgesetzt. Vorgenommene Formatierungen (fett, unterstrichen o.a.)
' koennen durchaus gewollt und sinnvoll sein, werden also nicht zurueckgesetzt:
With Target(1).Font
.Name = "Arial"
.Size = 8.5
End With
Target(1).RowHeight = 21
With Target(1).MergeArea
If .Rows.Count = 1 And .WrapText = True Then
CurrentRowHeight = .RowHeight
ActiveCellWidth = Target(1).ColumnWidth
For Each CurrCell In Selection
MergedCellRgWidth = CurrCell.ColumnWidth + _
MergedCellRgWidth
iX = iX + 1
Next
MergedCellRgWidth = MergedCellRgWidth + (iX - 1) * 0.71
.MergeCells = False
.Cells(1).ColumnWidth = MergedCellRgWidth
.EntireRow.AutoFit
PossNewRowHeight = .RowHeight
.Cells(1).ColumnWidth = ActiveCellWidth
.MergeCells = True
.RowHeight = IIf(CurrentRowHeight > PossNewRowHeight, _
CurrentRowHeight, PossNewRowHeight)
End If
End With
Application.ScreenUpdating = True
End If
End If
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Excel.Range)
' Falls die Meldung ueber eine zulange Texteingabe in D13 ignoriert wurde, wird der User
' ueber diesen Fehler informiert, wenn er eine andere Eingabezelle auswaehlt; aber -->
' der Inhalt von D13 darf nur geprueft werden, wenn die Markierung nicht in Zeile 13 oder
' Zeile 14 steht (fuehrt sonst unmittelbar nach einer zu langen Eingabe in D13 zu einer
' wechselseitigen Ausloesung von Worksheet_Change und Worksheet_SelectionChange):
If Target.Row = "13" Or Target.Row = "14" Then
Exit Sub
End If
If Len(Target(1)) > 1000 Then
MsgBox "Der Text umfasst mehr als 1000 Zeichen !" & Chr(10) & _
"Bitte kürzen Sie ihn entsprechend !", 48, "Text ist zu lang !"
Target(1).Select
Exit Sub
End If
' Wird ein Text in D13 ueber die Entf-Taste geloescht, ist dies fuer Excel kein
' Worksheet_Change Ereignis! Deshalb wird beim Auswaehlen einer beliebigen Zelle geprueft,
' ob D13 leer ist und die Zeilenhoehe ungleich 21 ist; ggf. wird zurueckgesetzt:
If Target(1) = "" And Rows("13").RowHeight 21 Then
Rows("13").RowHeight = 21
End If
End Sub