Ošetruje to vykonávanie pri celom stĺpci ale nie pri hlavičke, ošetruje viacnásobnú zmenu, nesúvislú oblasť, ignoruje inú hodnotu ako 1. Výsledok pre prvú bunku spĺňajúcu podmienky (hoci by ich bolo aj viac)
Kód: Vybrat vše
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Zmena As Range, Are As Range, Bunka As Range
Set Zmena = Intersect(Columns(3).Resize(Rows.Count - 1).Offset(1, 0), Target)
If Not Zmena Is Nothing Then
For Each Are In Zmena.Areas
For Each Bunka In Are.Cells
If Bunka.Value = 1 Then
Application.EnableEvents = False
Cells(2, 7).Resize(2).Value = Application.Transpose(Array(Format$(Now, "dd/mm/yyyy hh:nn:ss"), Bunka.Offset(0, -1).Value))
Application.EnableEvents = True
Exit Sub
End If
Next Bunka
Next Are
End If
End SubPrípadne si môžete uchovávať aj čas zmeny všetkých doteraz vyplnených 1. Len si budete ukladať ten čas do ďalšieho stĺpca, a nájdete poslednú pomocou vzorcov MAX() a MATCH()/POZVYHLEDAT().
Sem som pridal aj to, že sa pri zmene na inú hodnotu ako 1 (napr. zmazanie 1) bunka s časom vedľa zmaže.
Kód: Vybrat vše
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Zmena As Range, Are As Range, Bunka As Range, RNG1 As Range, RNG As Range, Cas As Date
Set Zmena = Intersect(Columns(3).Resize(Rows.Count - 1).Offset(1, 0), Target)
If Not Zmena Is Nothing Then
Cas = Now()
For Each Are In Zmena.Areas
For Each Bunka In Are.Cells
If Bunka.Value = 1 Then
If RNG1 Is Nothing Then Set RNG1 = Bunka.Offset(0, 1) Else Set RNG1 = Union(RNG1, Bunka.Offset(0, 1))
Else
If RNG Is Nothing Then Set RNG = Bunka.Offset(0, 1) Else Set RNG = Union(RNG, Bunka.Offset(0, 1))
End If
Next Bunka
Next Are
Application.EnableEvents = False
If Not RNG1 Is Nothing Then RNG1.Value = Cas
If Not RNG Is Nothing Then RNG.ClearContents
Application.EnableEvents = True
End If
End SubA ak by ste tých buniek menil naozaj veľa, celý stĺpec a pod., tak by to prechádzanie po jednej bunke trvalo dlho. Potom treba pristúpiť k načítaniu údajov do rýchlejšieho poľa.
Kód: Vybrat vše
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Zmena As Range, Are As Range, Cas As Date, Vyplnuji(), CasZmeny(), Pocet As Long, i As Long
Set Zmena = Intersect(Columns(3).Resize(Rows.Count - 1).Offset(1, 0), Target)
If Not Zmena Is Nothing Then
Cas = Now()
For Each Are In Zmena.Areas
Pocet = Are.Cells.Count
If Pocet = 1 Then
ReDim Vyplnuji(1 To 1, 1 To 1): Vyplnuji(1, 1) = Are.Value
ReDim CasZmeny(1 To 1, 1 To 1): CasZmeny(1, 1) = Are.Offset(0, 1).Value
Else
Vyplnuji = Are.Value
CasZmeny = Are.Offset(0, 1).Value
End If
For i = 1 To Pocet
CasZmeny(i, 1) = IIf(Vyplnuji(i, 1) = 1, Cas, Empty)
Next i
Application.EnableEvents = False
Are.Offset(0, 1).Value = CasZmeny
Application.EnableEvents = True
Next Are
End If
End SubZdá sa Vám to príliš komplikované na takú prkotinu? Vedzte, že ľudia dokážu robiť neskutočné veci v Exceli, a očakávať ešte neskutočnejšie.