Excel: Zellen Sperren bei Eingabe einer gewissen Zahl

  • #1
A

Arne2007

Mitglied
Themenersteller
Dabei seit
22.06.2007
Beiträge
14
Reaktionspunkte
0
Hallo Excelprofis :),

in den folgenden Zellen (D4:D15) kann man die Werte 1-5 eingeben. Sollte eine 1 eingegeben werden, sollen die anderen Zellen gesperrt und rot eingefärbt werden. Habt Ihr einen Vorschlag für ein Makro?

Vielen Dank für eure Hilfe im voraus,

Arne
 
  • #2
Makro ist nicht unbedingt nötig, geht auch mit den bedingten Formatierungen aus Menü Format. Da kannst du Bedingungen und Bezüge kombinieren.
 
  • #3
Hi,

danke für deine Antwort, aber bei der bedingeten formatierung finde ich den Punkt Zelle sperren nicht. Hab ich was übersehen?

--Arne
 
  • #4
ups ... das sperren hab ich übersehen. ist das unbedingt notwendig? knallrote zellen sind doch schon abschreckend genug ::)

sorry für die halbgare antwort

EXPERTEN VOR!!!!!!!!!!!!!
 
  • #5
kein problem :), aber das sperren muss leider sein.
 
  • #6
Hi zusammen,

der folgende Code sollte in der Code-Seite des Tabellenblattes zu liegen kommen. (Blattlasche markieren -> Code anzeigen)

Gruß Matjes :)
Code: 
Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
 
 Const sRANGE = D4:D15
 
 Dim r As Range, Zelle As Range
 
->Schnittmenge
 Set r = Application.Intersect(Range(sRANGE), Target)
 If r Is Nothing Then GoTo AUFRAEUMEN
 
->Im Bereich eine 1 suchen
 Set r = Range(sRANGE)
 For Each Zelle In r
  If CStr(Zelle.Value) = 1 Then Exit For
 Next
->Blattsperre aufheben
 r.Parent.Unprotect
 r.Locked = False
->wurde eine 1 gefunden ?
 If Not Zelle Is Nothing Then
 ->Zellen ohne 1 gesperrt setzen und Rot einfärben
  For Each Zelle In r
   Zelle.Interior.ColorIndex = xlColorIndexNone
   If CStr(Zelle.Value) <> 1 Then
    Zelle.Interior.ColorIndex = 3
    Zelle.Locked = True
   End If
  Next
 Else
 ->alle Zellen farblos setzen
  For Each Zelle In r
   Zelle.Interior.ColorIndex = xlColorIndexNone
  Next
 End If
->Blattsperre setzen
 r.Parent.Protect
 
AUFRAEUMEN:
 Set r = Nothing: Set Zelle = Nothing
End Sub
 
  • #7
Guten morgen Matjes,

der Code funktioniert einwandfrei :). Vielen Dank.
Nun sind nur leider DropDown-Felder definiert, sodass man die Zahl zwar nicht in die Zelle eingeben kann, aber per DropDown schon. Wenn Du dazu eine Idee hast, wäre ich dankbar, sonst müssen die DropDown Felder eben weg.


Viele Grüße,

Arne


LÖSUNG: In der Gültigkeit ZellenDropDown deaktivieren, dann hat man die Abfrage, ob die eingegeben Zahl stimmt, aber nicht das DropDown-Feld selber.
 
  • #8
Hallo zusammen,
noch eine Frage zu dem Code....
Wenn ich den Code auf mehrere Spalten anwenden möchte z.B. D14:d15 und F14:F15, wie muss ich dort verfahren?

Vielen Dank,

Arne
 
  • #9
Hallo Arne2007,

der Code muß etwas erweitert werden.

Gruß Matjes :)
Code: 
Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
 
 Dim r As Range, Zelle As Range
 Dim v As Variant
 v = Array(D4:D15, F4:F15)
 Dim x As Long
 Dim bFound As Boolean
 
 
->Schnittmenge vorhanden ?
 bFound = False
 For x = 0 To UBound(v)
  Set r = Application.Intersect(Range(v(x)), Target)
  If Not r Is Nothing Then bFound = True: Exit For
 Next
 If r Is Nothing Then GoTo AUFRAEUMEN
 
->Im Bereich eine 1 suchen
 bFound = False
 For x = 0 To UBound(v)
  Set r = Range(v(x))
  For Each Zelle In r
   If CStr(Zelle.Value) = 1 Then bFound = True: Exit For
  Next
  If bFound Then Exit For
 Next
 
->Blattsperre aufheben
 r.Parent.Unprotect
 r.Locked = False
 
 For x = 0 To UBound(v)
  Set r = Range(v(x))
 ->wurde eine 1 gefunden ?
  If bFound Then
  ->Zellen ohne 1 gesperrt setzen und Rot einfärben
   For Each Zelle In r
    Zelle.Interior.ColorIndex = xlColorIndexNone
    If CStr(Zelle.Value) <> 1 Then
     Zelle.Interior.ColorIndex = 3
     Zelle.Locked = True
    End If
   Next
  Else
  ->alle Zellen farblos setzen
   For Each Zelle In r
    Zelle.Interior.ColorIndex = xlColorIndexNone
   Next
  End If
 Next
 
->Blattsperre setzen
 r.Parent.Protect
 
AUFRAEUMEN:
 Set r = Nothing: Set Zelle = Nothing
End Sub
 
  • #10
Hallo,

leider hab ich mich etwas falsch ausgedrückt.. :( sry dafür!
Die Spalten D4:D15,F4:F15 und H4:H15 müssen unabhängig voneinander den code ausführen.
Es wäre sehr nett, wenn Du mir nochmal helfen könntest.
Grundsätzlich müssten die Arrays immer unabhängig voneinader betrachtet werden. Sehr schön wäre es, wenn man dann noch weitere Arrays definieren könnte, sodass man die Tabelle noch um mehrere Felder (Arrays) erweitern kann.

Vielen Dank und Grüße,

Arne
 
  • #11
Dann nehmen wir du alte Variante und variieren sie etwas.

Gruß Matjes :)
Code: 
Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
 
 Dim r As Range, Zelle As Range, v As Variant, sRange As String, x As Long
 v = Array(D4:D15, F4:F15, H4:H15)-><<<-- HIER kannst du noch weiter Bereiche anhängen
 
 
 For x = 0 To UBound(v)
  sRange = v(x)

 ->Schnittmenge
  Set r = Application.Intersect(Range(sRange), Target)
  If r Is Nothing Then GoTo NAECHSTERUNDE
 
 ->Im Bereich eine 1 suchen
  Set r = Range(sRange)
  For Each Zelle In r
   If CStr(Zelle.Value) = 1 Then Exit For
  Next
 ->Blattsperre aufheben
  r.Parent.Unprotect
  r.Locked = False
 ->wurde eine 1 gefunden
  If Not Zelle Is Nothing Then
  ->Zellen ohne 1 gesperrt setzen und Rot einfärben
   For Each Zelle In r
    Zelle.Interior.ColorIndex = xlColorIndexNone
    If CStr(Zelle.Value) <> 1 Then
     Zelle.Interior.ColorIndex = 3
     Zelle.Locked = True
    End If
   Next
  Else
  ->alle Zellen farblos setzen
   For Each Zelle In r
    Zelle.Interior.ColorIndex = xlColorIndexNone
   Next
  End If
 ->Blattsperre setzen
  r.Parent.Protect
NAECHSTERUNDE:
 Next
 
AUFRAEUMEN:
 Set r = Nothing: Set Zelle = Nothing
End Sub
 
  • #12
Hi Matjes,

gerade gestestet, Kollegen alle zufrieden, vielen Dank :D.

Grüße,

Arne
 
Thema:

Excel: Zellen Sperren bei Eingabe einer gewissen Zahl

ANGEBOTE & SPONSOREN

Neueste Themen

Statistik des Forums

Themen
113.839
Beiträge
707.962
Mitglieder
51.492
Neuestes Mitglied
Janus36
Oben