AW: aktuelle Zelladresse als Fixwert speichern
04.02.2013 17:27:09
Rolf
Hallo Hajo,
habe zwischenzeitlich etwas anderes ausprobiert. Siehe meinen Thread vom 03.02.2013 18:32:21. Bereitet aber immer noch Probleme in puncto Pfeiltasten. Hier der Code:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim UrlPlan As String 'Eingabebereich
Dim maxUrlauber As String 'max. Anzahl Urlauber pro Tag
Dim start1 As Long, start2 As Long 'Startzeile Block1 bzw. Block2
Dim sum1 As Long, sum2 As Long 'Summenzeile Block1 bzw. Block2
Dim AZ As String, spB As String 'aktuelle Zelle, aktuelle Spalte
Dim Bereich As Range 'Datenbereich im aktuellen Block (Teil-Spalte)
Dim zelle As Range 'Zelle(n) in "Bereich"
Dim i As Integer 'Anzahl gefüllter Zellen in "Bereich"
Dim WS As String 'Name dieses Worksheets
UrlPlan = Range("UrlPlan").Address
maxUrlauber = Range("maxUrlauber").Address
start1 = Range("start1").Row
start2 = Range("start2").Row
sum1 = Range("sum1").Row
sum2 = Range("sum2").Row
WS = ActiveSheet.Name
If Intersect(Target, Range(UrlPlan)) Is Nothing Then
Exit Sub
Else
'aktive Zelladresse und Spaltenbuchstabe(n) in Variablen hinterlegen, _
getrennt nach "Block1" und "Block2"
AZ = ActiveCell.Address
spB = Mid(AZ, 2, InStr(2, AZ, "$") - 2)
'Löscht den Eintrag "Urlaubswunsch", wenn genehmigt
With Target
If .Interior.ColorIndex = 36 And .Offset(1, 0).Value "" Then
.Offset(1, 0).ClearContents
.Offset(1, 0).Interior.ColorIndex = 2
.Offset(1, 0).Font.ColorIndex = 3
End If
End With
'Anzahl Zelleinträge ermitteln und in der Variablen "i" hinterlegen
If za "" Then i = i + 1
Next zelle
Else
Set Bereich = Range(spB & start2 & ":" & spB & sum2 - 1)
For Each zelle In Bereich
If zelle.Value "" Then i = i + 1
Next zelle
End If
'Warnmeldung, wenn i > maximal erlaubte Anzahl Urlauber pro Tag
If i > Range(maxUrlauber).Value Then
MsgBox _
"Die Anzahl Ur-Wünsche überschreitet das zulässige Maximum!" & _
vbLf & vbLf & "Bitte sprich dich mit deinen Kolleginnen / " & _
"Kollegen ab, " & vbLf & "oder wähle einen anderen " & _
"Zeitraum.", vbOKOnly + vbExclamation, "Warnhinweis"
'Ändert die Hintergrundfarbe der Zelle in rot und die Schriftfarbe in blau
With Target
.Interior.ColorIndex = 3
.Font.ColorIndex = 5
End With
End If
End If
End Sub
Gruß, Rolf