Zobrazení poslední Vyřešeno

[junis]

zkouska-excel.xlsm

Šlo by nějak zajistit aby pokud zapíšu hodnotu 1 do nějakého řádku sloupce 3 aby se mi v bunce G3 zobrazila hodnota z tohoto řádku ze sloupce 2. Myslím tím, aby se mi v té buňce G3 zobrazovala vždy jen hodnota ze sloupce 2 buňky kde byla na řádku poslední provedená změna.
Povedlo se mi aby se mi vždy zobrazil čas provedené poslední změny ve sloupci 3 do pole G2. Potřeboval bych vyplnit ještě pole G3

Zapeklitá věc. Díky

[Reklama]

[d1amond]

Určitě by bylo namístě, dát sem xlsx s příkladem. Jinak samozřejmě to řešitelné je, ve VBA.

[junis]

OK. Přiložil jsem soubor do původního dotazu pro lepší pochopení. Díky

[elninoslov]

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 Sub

Prí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 Sub

Dodatečně přidáno po 7 hodinách 32 minutách 48 vteřinách:
A 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 Sub

Zdá 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.

[junis]

Fukguje to, chtěl jsem to upravit do připraveného souboru, ale nedaří se mi.
Možná mi s tím pomůžete. Do bílého pole (list Inventura) se načítají nebo zapisují nalezená čísla, z vyhledávacího pole se nalezená označí v (listu Sestava) ve sloupci Q jedničkou. Z listu Sestava se vše kopíruje i do (listu Inventura!!) Do oranžového pole K2 v (listu Inventura) bych potřeboval zobrazovat vždy poslední nalezené číslo z (listu Sestava) slouce N, klidně podle času nalezení který se zobrazuje ve sloupci R.
Přikládám soubor. Měl jsem asi přiložit hned tohle, omlouvám se, ale musel jsem to nějak upravit.
Díky moc
Je to hrozně složité co?

soubor1.zip

[elninoslov]

Skúste

[junis]

Do oranžového pole K2 v (listu Inventura) bych potřeboval zobrazovat vždy poslední nalezené číslo z (listu Sestava) slouce N. Ne časovou značku, ale hodnotu, tedy číslo, ze sloupce N z listu sestava. Tedy z vyhledávacího pole.
Jinak ty časy nalezení se již generují do listu sestava, tak v inventuře, jsou zbytečná.

Klidně by stačilo, tuto hodnotu vyvolat kliknutím na tlačítko, vyskočil by MsgBox a zobrazil poslední hodnotu. To by bylo ještě lepší.

Děkuji

[elninoslov]

Kód: Vybrat vše

=INDEX(Sestava!N2:N10005;MATCH(MAX(Sestava!R2:R10005);Sestava!R2:R10005;0))
=INDEX(Sestava!N2:N10005;POZVYHLEDAT(MAX(Sestava!R2:R10005);Sestava!R2:R10005;0))

alebo MsgBox

Kód: Vybrat vše

Sub Oznam()
Dim Zaznam As String, Cas As Date

    On Error Resume Next
    With Worksheets("Sestava")
        Cas = WorksheetFunction.Max(.Range("R2:R10005"))
        Zaznam = CStr(.Cells(1 + WorksheetFunction.Match(CDbl(Cas), .Range("R2:R10005").Value2, 0), "N").Value)
    End With
   
    MsgBox IIf(Err.Number = 0, "Poslední záznam :" & vbNewLine & vbNewLine & "Čas" & vbTab & Format(Cas, "d.m.yyyy hh:nn:ss") & vbNewLine & "Záznam" & vbTab & Zaznam, "Žádný záznam")
    On Error GoTo 0
End Sub

[junis]

A Makrem přes to tlačítko? Díky

Dodatečně přidáno po 3 hodinách 49 minutách 52 vteřinách:
Ano, tohle je přímo super. Děkuji moc za velkou pomoc.