ich möchte über das ganze Tabellenblatt die verbundenen Zeilen automatisch in der Höhe anpassen lassen. Dazu habe ich folgenden Code hier im Forum gefunden. Wie muss der Code umgeschrieben werden damit ich alle Zeilen damit anspreche?
arrZ = Array(13, 20, 28, 15)
Gruß Tom
------------------------------
in ein normales Modul:
Option Explicit
' nach: www.herber.de/mailing/137101h.htm
' "Zeilenhöhe bei verbundenen Zellen anpassen"
Sub ZeilenhoeheVerbundene(lngZeileNr As Long)
' Parameter ist die Zeilennummer.
' In einer Zeile kann es mehrere verbundene Zellen geben.
Dim sngHoehe As Single, cc As Integer, rngC As Range
Dim sngActWid As Single, rngM As Range, sngMergWid As Single
Application.ScreenUpdating = False
With Rows(lngZeileNr)
.AutoFit
sngHoehe = .RowHeight ' Mindesthöhe (insbes. nicht-verbundene Zellen)
End With
For cc = 1 To Cells(lngZeileNr, Columns.Count).End(xlToLeft).Column
If Cells(lngZeileNr, cc) > "" And Cells(lngZeileNr, cc).MergeCells Then
Set rngC = Cells(lngZeileNr, cc)
If Len(rngC) > 1000 Then
MsgBox "Der Text in " & rngC.Address(0, 0) & " hat über 1000 Zeichen !" _
& vbLf & vbLf & "Bitte kürzen!", vbCritical, "ZeilenhoeheVerbundene"
rngC.Select
Exit Sub
End If
With rngC.MergeArea
If .Cells(1).Address = rngC.Address And .WrapText = True Then
sngActWid = rngC.ColumnWidth ' Merken zum Wiederherstellen
' ---------------------------------------- Gesamtbreite rechnen
For Each rngM In .Cells
sngMergWid = rngM.ColumnWidth + sngMergWid
Next
sngMergWid = sngMergWid + (.Count - 1) * 0.71
' ----------------- Merge aufheben, Zellbreite auf Gesamtbreite
.MergeCells = False
rngC.ColumnWidth = sngMergWid
' ---------------------------------- max. optim. Höhe ermitteln
.EntireRow.AutoFit
sngHoehe = Application.Max(sngHoehe, rngC.Height)
' --------------------------- Breite und Merge wiederherstellen
rngC.ColumnWidth = sngActWid
.MergeCells = True
End If
End With
End If
Next cc
Rows(lngZeileNr).RowHeight = sngHoehe ' max. optim. Höhe einstellen
Application.ScreenUpdating = True
End Sub
Sub tst()
ZeilenhoeheVerbundene 20
End Sub
in das Modul der Tabelle, auf die der Code wirken soll:
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rng As Range, arrZ, colZ As New Collection, ii As Long
arrZ = Array(13, 20, 28, 15) ' Nummern der überwachten Zeilen anpassen
For Each rng In Target ' falls mehrere Zellen auf einmal geändert
If Not IsError(Application.Match(rng.Row, arrZ, 0)) Then
On Error Resume Next
colZ.Add rng.Row, CStr(rng.Row) ' hier werden Dubletten vermieden
On Error GoTo 0
End If
Next rng
For ii = 1 To colZ.Count
ZeilenhoeheVerbundene colZ(ii) ' Höhen der gesammelten Zeilen optimieren
Next ii
Set colZ = New Collection
End Sub