Makro pro zápis historie Vyřešeno

Programy pro práci v kanceláři (Word, Excel, Access…=>Office)

Moderátor: Mods_senior

Woodpecker
nováček
Příspěvky: 17
Registrován: únor 10
Pohlaví: Muž
Stav:
Offline

Makro pro zápis historie

Příspěvekod Woodpecker » 15 úno 2016 22:52

Ahoj,
potřeboval bych makro pro sledování změn u odemčených buněk v přiloženém příkladu, tak aby k zápisu změn docházelo na zamčeném druhém listu. Bohatě postačuje datum, stará a nová hodnota buňky. Sledování změn mi nevyhovuje, nejedná se o sdílený dokument. Dnes jsem nacházel makra pro sledování změn u sdílených dokumentů nebo pro mě nevyužitelné. Používám MSO 2007. Díky Moc za pomoc.

Heslo: 123
Je to reálné nebo absolutní nesmysl?
Přílohy
Test historie.xlsm
(8.8 KiB) Staženo 24 x

Reklama
cmuch
Level 4.5
Level 4.5
Příspěvky: 1544
Registrován: březen 11
Bydliště: Drsná Vysočina :D
Pohlaví: Muž
Stav:
Offline

Re: Makro pro zápis historie  Vyřešeno

Příspěvekod cmuch » 19 úno 2016 18:26

Toto vlož do modulu listu Data

Kód: Vybrat vše

Dim OldVal, Pozice

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    OldVal = Target
    Pozice = Target.Address
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim KeyCells As Range, i, radek
    Dim JmenoPC, JmenoExcel
   
    Set KeyCells = Range("A1:AZ9999") ' *** hlídaná oblast ************

    JmenoPC = Environ("UserName")
    JmenoExcel = Application.UserName
    NewVal = Target.Value
                       
    If Not Application.Intersect(KeyCells, Range(Target.Address)) Is Nothing Then
        With Sheets("Zmeny")
            .Protect UserInterfaceOnly:=True
            radek = 1   'nastaveni radek jako 1
            For i = 1 To .Cells(.Cells.Rows.Count, "A").End(xlUp).Row + 1
                If .Cells(i, 1) <> "" Then
                    radek = radek + 1
                End If
            Next
   
            .Cells(radek, 1).Value = Format$(Now, "yyyy/mm/dd hh:nn:ss")
            .Cells(radek, 2).Value = JmenoPC
            .Cells(radek, 3).Value = JmenoExcel
            .Cells(radek, 4).Value = Pozice
            .Cells(radek, 5).Value = OldVal
            .Cells(radek, 6).Value = NewVal
        End With
   
    End If
End Sub


  • Mohlo by vás zajímat
    Odpovědi
    Zobrazení
    Poslední příspěvek
  • Makro pro myš Rapture Python
    od mmmartin » 27 srp 2023 15:18 » v Problémy s hardwarem
    9
    1111
    od mmmartin Zobrazit poslední příspěvek
    29 srp 2023 16:47

Zpět na “Kancelářské balíky”

Kdo je online

Uživatelé prohlížející si toto fórum: Žádní registrovaní uživatelé a 2 hosti