Zelle gelockt nach ActiveSheet.protect
03.12.2019 15:47:39
hkoepp63
ich muss aus einer Tabelle den Schreibschutz rausnehmen um "gemergte Zellen" in der Zeilenhöhe automatisch anzupassen. Es funktioniert auch alles. Der einzige Fehler ist, daß danach der Schutz der Zelle(n) eingeschlatet wird... Die Zellen J22:S22 müssen aber beschreibbar bleiben.
Anbei der komplette Code:
Option Explicit
' nach: www.herber.de/mailing/137101h.htm
' "Zeilenhöhe bei verbundenen Zellen anpassen"
Sub ZeilenhoeheVerbundene(lngZeileNr As Long)
ActiveSheet.Unprotect Password:="***"
' 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
ActiveSheet.Protect Password:="***"
End Sub
Sub tst()
ZeilenhoeheVerbundene 20
End Sub
Wie bekomme ich das hin, daß diese Zelle(n) ungeschützt bleiben?Vielen Dank im Voraus für Eure Hilfe.
Beste Grüße
Hinnerk