Kód: Vybrat vše
Private Sub Worksheet_Change(ByVal Target As Range)
' udalostni procedura snizi stav ks v prislusnem zaznamu na list1,
' zaznamy na list1 jsou jedinecne
' deklarace promennych
Dim Cll As Range, SBlk As Range, OK As Boolean
' omezeni rozsahu promenne target na jednu bunku pri mazani bloku bunek
Set Target = Target.Resize(1, 1)
' test, zda Target je ze sloupce D:D
If Not Intersect(Target, Me.Range("d:d")) Is Nothing Then
' nastavi promennou OK na hodnotu False
OK = False
' nastavit blok bunek na listu1
With Worksheets("list1")
Set SBlk = Intersect(.UsedRange, .Range("a:a"))
End With
' prohledat sloupec A:A na listu1, hledat hodnotu z list2!Axx - nazev
With SBlk
Set Cll = .Find(Target.Offset(0, -3).Value, LookIn:=xlValues, LookAt:=xlWhole)
If Not Cll Is Nothing Then
' nalezeno ve sloupci A:A, overit zda se shoduje upresneni
If Cll.Offset(0, 1).Value = Target.Offset(0, -2).Value Then
' overit, zda seshoduje i nazev
If Cll.Offset(0, 2).Value = Target.Offset(0, -1).Value Then
' snizit hodnotu kusu na listu1, kdyz bude vysledek >=0
If Cll.Offset(0, 3).Value - Target.Value >= 0 Then
Cll.Offset(0, 3).Value = Cll.Offset(0, 3).Value - Target.Value
Else
MsgBox "Zustatek je < 0, blabla..."
' odstranit vlozenou hodnotu kusu na listu2, potlacit prepocet a volani procedury
Application.EnableEvents = False
Target.Value = vbNullString
Application.EnableEvents = True
End If
OK = True
End If
End If
End If
End With
Set Cll = Nothing
Set SBlk = Nothing
If Not OK Then MsgBox "Nenalezeno...blabla"
End If
End Sub