Új hozzászólás Aktív témák

• #16001 Mutt senior tag lacid90 #15981

  Új Válasz 2013-01-04 20:51:23 #16001

  Új hozzászólás

  Összes hozzászólása itt Válaszok az összes hozzászólására itt Válaszok erre a hozzászólásra

  Privát üzenet küldése

  

  Mutt

  senior tag

  válasz lacid90 #15981 üzenetére

  Hello,

  A megadott adatok alapján faragtam a kódon és felraktam egy mintát ide.

  A kód pedig így néz ki, továbbra is egy Backup munkalapra menti a módosításokat:

  Option Explicit
  Public vEredeti 'ez tartalmazza majd az eredeti értéket
  
  Private Sub Worksheet_Activate()
  
  'ha megnyitjuk a lapot akkor egyből jegyezzük meg hogy mi van a B1 cellában
  vEredeti = ActiveSheet.Range("B1").Value
  
  End Sub
  
  Private Sub Worksheet_Change(ByVal Target As Range)
  Const vBackupSheet As String = "Backup"
  Dim vLastRow
  Dim wsNew As Worksheet
  Dim wsCurrent As String
  
  'ha a C1 cella értéke 0 vagy üres
  If ActiveSheet.Range("C1").Value = 0 Or ActiveSheet.Range("C1").Value = "" Then
  
  'megnézzük hogy létezik-e a munkalap ahova a korábbi értékeket mentjük
  On Error Resume Next
  Set wsNew = Worksheets(vBackupSheet)
  If Err Then
  wsCurrent = ActiveSheet.Name
  Set wsNew = Sheets.Add
  With wsNew
  .Name = vBackupSheet
  'ha akarod akkor a lenti sorral rejtetté tudod tenni a lapot
  '.Visible = xlSheetHidden
  End With
  Sheets(wsCurrent).Activate
  End If
  
  'megnézzük hogy melyik az utolsó sor a backup munkalapon
  vLastRow = Application.WorksheetFunction.CountA(ThisWorkbook.Sheets(vBackupSheet).Range("A:A")) + 1
  
  'ha már nincs a munkalapon több üres sor akkor leállunk a naplózással
  If vLastRow > ThisWorkbook.Sheets(vBackupSheet).Rows.Count Then
  MsgBox "Nincs több hely a mentésre!", vbOKOnly, "Hiba"
  Exit Sub
  End If
  
  'adunk egy fejlécet a backup munkalapnak
  If vLastRow = 1 Then
  ThisWorkbook.Sheets(vBackupSheet).Range("A" & vLastRow) = "Eredeti érték"
  vLastRow = vLastRow + 1
  End If
  
  'mentjük az eredeti értéket és hogy melyik cellából jött
  ThisWorkbook.Sheets(vBackupSheet).Range("A" & vLastRow) = vEredeti
  End If
  
  End Sub
  
  Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  
  'ha az A1 cellára lépünk, csak akkor jegyezzük meg a B1 értékét
  If Target.Address = "$A$1" Then
  vEredeti = ActiveSheet.Range("B1").Value
  End If
  
  End Sub

  Ami pluszt beletetettem, hogy a munkalap megnyitásakor már megjegyzi az eredeti értéket, mivel előfordulhat az az esete hogy éppen az A1 cellában állsz és az értéket felülírod mozgás nélkül.
  Fontos, hogy a makró csak akkor műkődik ha az A1 cellába mindig visszamész, vagyis ha mindig a szerkesztősorban változtatod a cella értékét akkor nem fog műkődni mert a cellából nem mész el.

  üdv.

Új hozzászólás Aktív témák