Makro Zelle Schutz aufheben

Private Sub Worksheet_Change(ByVal Target As Excel.Range) Application.ScreenUpdating = False If Intersect(Target, Range("A10:C20")) Is Nothing Then Exit Sub ActiveSheet.Unprotect ("kk") On Error GoTo fehler Application.EnableEvents = False If Target.Count = 1 Then Target = Application.Proper(Target) End If fehler: Application.EnableEvents = True 'Wenn mehr als eine Zelle markiert wurde dann Makro beenden If Target.Count > 1 Then Exit Sub Select Case Target.Value Case "U" Target.Interior.ColorIndex = 35 Case "F" Target.Interior.ColorIndex = 35 Selection.Font.ColorIndex = 1 'schwarz End Select ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios _ :=True, Password:= ("kk") Application.ScreenUpdating = True End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Option Explicit Private Sub Worksheet_Change(ByVal Target As Excel.Range) Application.ScreenUpdating = False If Intersect(Target, Range("A10:C20")) Is Nothing Then Exit Sub On Error GoTo fehler Application.EnableEvents = False If Target.Count = 1 Then Target = Application.Proper(Target) End If fehler: Application.EnableEvents = True 'Wenn mehr als eine Zelle markiert wurde dann Makro beenden If Target.Count > 1 Then Exit Sub ActiveSheet.Unprotect ("kk") Select Case Target.Value Case "U" Target.Interior.ColorIndex = 35 Case "F" Target.Interior.ColorIndex = 35 Selection.Font.ColorIndex = 1 'schwarz End Select ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios _ :=True, Password:=("kk") Application.ScreenUpdating = True End Sub

Option Explicit Private Sub Worksheet_Change(ByVal Target As Excel.Range) ' Wenn mehr als eine Zelle markiert Makro nicht ausführen If Target.Count = 1 Then Application.EnableEvents = False Application.ScreenUpdating = False If Intersect(Target, Range("A10:C20")) Is Nothing Then Exit Sub ActiveSheet.Unprotect ("kk") Select Case Left(UCase(Target.Value), 1) Case "U" Target.Interior.ColorIndex = 35 Case "F" Target.Interior.ColorIndex = 35 Selection.Font.ColorIndex = 1 'schwarz End Select ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios _ :=True, Password:=("kk") Application.EnableEvents = True Application.ScreenUpdating = True End If End Sub

Private Sub Worksheet_Change(ByVal Target As Excel.Range) If Target.Count = 1 Then Application.EnableEvents = False Application.ScreenUpdating = False If Intersect(Target, Range("D14:N53")) Is Nothing Then Exit Sub ActiveSheet.Unprotect (getStrPasswort) Select Case Left(UCase(Target.Value), 1) Case "U", "F" Target.Interior.ColorIndex = 35 End Select ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios _ :=True, Password:=getStrPasswort Application.EnableEvents = True Application.ScreenUpdating = True End If End Sub

Hallo Kurt
Ich hatte mich in meinem Beispiel
auf Deine 1.hochgeladenen Datei bezogen.
Dort funktionierte doch alles. Bis auf das das PW noch nicht aktiv war.
In Deiner 2.hochgeladenen Datei habe ich festgestellt,
das nicht überall die bedingte Formatierung eingetragen war.
Bitte welche Datei meinst Du jetzt.
Ich würde ja auch gerne helfen, aber ich verstehe das Poblem nicht.
siehe mein letzter Beitrag:
https://www.herber.de/forum/archiv/1048to1052/t1051271.htm#1051361
Ich gehe nachwievor davon aus, das Du den Eintrag in die Zellen nur per DropDown der Gültigkeitsliste zulassen willst.
Ist das korrekt ?
also:
Bitte erläutere nochmal genau was Du willst bzw.was nicht funktioniert und in welcher Datei.
Gruß Matthias

Private Sub Worksheet_Change(ByVal Target As Excel.Range) If Intersect(Target, Range("D14:Q53")) Is Nothing Then Exit Sub If Target.Count > 1 Then Exit Sub If Not Target.HasFormula Then Application.EnableEvents = False Target.Value = UCase(Target.Value) Application.EnableEvents = True End If CommandButton2_Click '=Schutz aufheben Select Case Left(UCase(Target.Value), 1) Case Is = "U": Target.Interior.ColorIndex = 35 Case Is = "F": Target.Interior.ColorIndex = 35 '43 End Select Select Case Left(UCase(Target.Value), 3) Case Is = "B00" Target.Interior.ColorIndex = 36 'hellogelb Target.Font.ColorIndex = 36 Case Is = "B01" Target.Interior.ColorIndex = 40 'hellorgange Target.Font.ColorIndex = 40 Case "" Target.Interior.ColorIndex = xlNone Target.Font.ColorIndex = 1 End Select SchutzEin End Sub

Hallo Matthias,
habe das Makro so:


Private Sub Worksheet_Change(ByVal Target As Excel.Range)
If Intersect(Target, Range("D14:Q53")) Is Nothing Then Exit Sub
If Target.Count > 1 Then Exit Sub
If Not Target.HasFormula Then
Application.EnableEvents = False
Target.Value = UCase(Target.Value)
Application.EnableEvents = True
End If
CommandButton2_Click
Select Case Left(UCase(Target.Value), 1)
Case "U":   Target.Interior.ColorIndex = 35
Case "F":   Target.Interior.ColorIndex = 35 '43
Select Case Left(UCase(Target.Value), 3)
Case Is = "B00"
Target.Interior.ColorIndex = 36         'hellogelb
Target.Font.ColorIndex = 36
Case Is = "B01"
Target.Interior.ColorIndex = 40        'hellorgange
Target.Font.ColorIndex = 40
Case ""
Target.Interior.ColorIndex = xlNone
Target.Font.ColorIndex = 1
End Select
SchutzEin
End Sub

leider keine Reaktion von Farbe Hintergrund und Schriftfarbe.
Grün wird ebenfalls NICHT eingefärbt.
Es kommt auch keine Fehlermeldung! Obwohl Gültigkeitsprüfung drin ist, bitte schau doch mal in die Tabelle, bitte.
gruß Kurt MG

Beliebteste Forumthreads (12 Monate)

26
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

302 Forumthreads zu ähnlichen Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Makro Zelle Schutz aufheben

26 Beiträge zum Forumthread Beiträge zu diesem Forumthread

302 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

26
Beiträge zum Forumthread

Beiträge zu diesem Forumthread