So, aber jetzt
16.11.2014 18:19:54
Michael
Hallo Sabbel,
ich hab das Ding nochmal überarbeitet und mehrere (nicht zusammenhängende) Bereiche mit Namen versehen. Dabei bin ich seltsamerweise darüber gestolpert, daß (zumindest) Excel (2000) scheinbar eine Grenze für die Anzahl der Teilbereich hat, und zwar 19 x 4 x zwei_zusammenhängende_Zellen, das sind 76 Bereiche bzw. 152 Zellen, Zahlen, die für Informatiker völlig unüblich sind, derweil sie so rein gar nichts mit 2er Potenzen zu tun haben.
Sei's drum, hab ich halt je zwei Bereiche definiert und mache die Abfrage auf beide, das tut auch.
Mit diesen Bereichen entfällt das Hilfsblatt:
Private Sub Worksheet_Change(ByVal Ziel As Excel.Range)
' Quellen u.a.
' _
https://www.herber.de/forum/archiv/632to636/633563_Wie_funktioniertINTERSECT.html
' http://www. _
scheidgen.de/Excel/VBA/markierung_in_bereich_pruefen-01.htm
Dim FundZelle As Range
Dim rngZelle As Range
Dim RegalZelle, suchen As String
Dim status, spalte_links, farben, gefunden As Integer
status = 0
' ************* Fall 1: Anwender ändert Wert im rosa Bereich
If Not Application.Intersect(Ziel, Range("RosaRegalWert")) Is Nothing Then status = 1
' ************* Fall 2: Anwender ändert Status
If Not Application.Intersect(Ziel, Range("RegalStatus")) Is Nothing Then status = 2
' Wenn woanders was geändert wird, ist status unverändert =0
If status = 0 Then Exit Sub
' raus aus dem Programm!
spalte_links = status
' also 1 nach links, wenn rosa Wert bzw.
' 2 nach links, wenn Status eingegeben
suchen = Cells(Ziel.Row, Ziel.Column - spalte_links).Value
If status = 2 Then
status = Cells(Ziel.Row, Ziel.Column).Value
Else
status = Cells(Ziel.Row, Ziel.Column + 1).Value
End If
gefunden = 0
Set FundZelle = Range("Beschriftung").Find(What:=suchen, _
LookIn:=xlValues, MatchCase:=False)
If Not FundZelle Is Nothing Then
gefunden = 1
Else
Set FundZelle = Range("Beschriftung2").Find(What:=suchen, _
LookIn:=xlValues, MatchCase:=False)
If Not FundZelle Is Nothing Then gefunden = 1
End If
' Hier bitte irgendwie Fehler abfangen
If gefunden = 0 Then
MsgBox suchen & " nicht gefunden"
Exit Sub
End If
Set rngZelle = Cells(FundZelle.Row, FundZelle.Column + 1)
' MsgBox "rngZelle: " & rngZelle.Address
' Es folgt die Variante, die ich gemeint habe mit "Matrix" für Farben
Select Case rngZelle.Value
Case Is = ""
farben = 1
Case Is = "0"
farben = 2
Case Is = "Leihgerät"
farben = 3
Case Is = "Eigen"
farben = 4
Case Is Range("W18")
If status = 3 Then farben = 7
If status = 4 Then farben = 8
If (status 4) And (status 3) Then farben = 6
End Select
rngZelle.Interior.Color = Range("AI" & 12 + farben).Interior.Color
' holt sich einfach die Farbe aus der Matrix, d.h., Du kannst die Farben
' dort ändern, ohne Dich um die lästeign RGB-Werte kümmern zu müssen.
' Das Erweitern der Matrix ist programmiertechnisch auch ziemlich simpel.
End Sub
Weil ich schon dabei war, hab ich auch Bereiche für Deine zweite Funktion definiert: die wird dadurch deutlich kürzer.
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Excel.Range, Cancel As Boolean)
Dim Lager As Long
Dim status As Integer
' MsgBox Target.Address
status = 0
' ************* A1 bis J7
If Not Application.Intersect(Target, Range("RegalInhalt")) Is Nothing Then status = 1
' ************* J2 bis M8
If Not Application.Intersect(Target, Range("ReaglInhalt2")) Is Nothing Then status = 2
' Wenn woanders geklickt wird, ist status unverändert =0
If status = 0 Then Exit Sub
' hier gehört sich eine Abfrage rein, ob der Wert numerisch ist, sonst spuckts
Lager = Target.Cells(1, 1).Value
Range("W17") = Lager
If Range("W17") > 0 Then
MsgBox "call wird aufgerufen"
' Call Lagr
Else
Range("A1").Select
Exit Sub
End If
Cancel = True
End Sub
So, hier noch die Datei: https://www.herber.de/bbs/user/93802.xls
Happy Exceling,
Michael