Private
Sub
Worksheet_Change(
ByVal
Target
As
Range)
Dim
ProtokollSheet
As
Worksheet
Dim
letzteZeile
As
Long
Dim
Benutzer
As
String
Dim
Aktion
As
String
If
Target.Worksheet.Name =
"Lager"
Then
Set
ProtokollSheet = ThisWorkbook.Sheets(
"Protokoll"
)
letzteZeile = ProtokollSheet.Cells(ProtokollSheet.Rows.Count, 1).
End
(xlUp).Row + 1
Benutzer = Application.UserName
If
Target.Value =
""
Then
Aktion =
"Gelöscht"
Else
Aktion =
"Geändert: "
& Target.Value
End
If
ProtokollSheet.Cells(letzteZeile, 1).Value = Benutzer
ProtokollSheet.Cells(letzteZeile, 2).Value = Now()
ProtokollSheet.Cells(letzteZeile, 3).Value = Target.Address
ProtokollSheet.Cells(letzteZeile, 4).Value = Aktion
ThisWorkbook.Save
End
If
Dim
BestandRange1
As
Range
Dim
ProduktRange1
As
Range
Dim
BestandCell1
As
Range
Dim
ProduktCell1
As
Range
Dim
BestandThreshold1
As
Integer
Dim
BestandRange2
As
Range
Dim
ProduktRange2
As
Range
Dim
BestandCell2
As
Range
Dim
ProduktCell2
As
Range
Dim
BestandThreshold2
As
Integer
Dim
MailAdresse
As
String
Dim
Betreff
As
String
Dim
Nachricht
As
String
Set
BestandRange1 = Range(
"E2:E9"
)
Set
ProduktRange1 = Range(
"C2:C9"
)
BestandThreshold1 = 20
Set
BestandRange2 = Range(
"E11:E51"
)
Set
ProduktRange2 = Range(
"C11:C51"
)
BestandThreshold2 = 1
MailAdresse =
"E-Mail"
Betreff =
"Bestandsbenachrichtigung"
If
Not
Intersect(Target, BestandRange1)
Is
Nothing
Then
For
Each
BestandCell1
In
Intersect(Target, BestandRange1)
If
BestandCell1.Value < BestandThreshold1
Then
Set
ProduktCell1 = ProduktRange1.Cells(BestandCell1.Row - ProduktRange1.Cells(1).Row + 1)
Nachricht =
"Der Bestand des Produkts "
& ProduktCell1.Value &
" beträgt "
& BestandCell1.Value &
"."
SendEmail MailAdresse, Betreff, Nachricht
End
If
Next
BestandCell1
End
If
If
Not
Intersect(Target, BestandRange2)
Is
Nothing
Then
For
Each
BestandCell2
In
Intersect(Target, BestandRange2)
If
BestandCell2.Value < BestandThreshold2
Then
Set
ProduktCell2 = ProduktRange2.Cells(BestandCell2.Row - ProduktRange2.Cells(1).Row + 1)
Nachricht =
"Der Bestand des Produkts "
& ProduktCell2.Value &
" beträgt "
& BestandCell2.Value &
"."
SendEmail MailAdresse, Betreff, Nachricht
End
If
Next
BestandCell2
End
If
End
Sub
Sub
SendEmail(
ByVal
MailAdresse
As
String
,
ByVal
Betreff
As
String
,
ByVal
Nachricht
As
String
)
Dim
objOutlook
As
Object
Dim
objMail
As
Object
Set
objOutlook = CreateObject(
"Outlook.Application"
)
Set
objMail = objOutlook.CreateItem(0)
With
objMail
.
To
= MailAdresse
.Subject = Betreff
.Body = Nachricht
.Send
End
With
Set
objMail =
Nothing
Set
objOutlook =
Nothing
End
Sub