Preskoči na glavno vsebino

Kako zapisati spreminjajoče se vrednosti v celico v Excelu?

Avtor: Siluvia Zadnja sprememba: 2020-12-10

Kako zabeležiti vsako spreminjajočo se vrednost za pogosto spreminjajočo se celico v Excelu? Na primer, prvotna vrednost v celici C2 je 100, pri spreminjanju številke 100 na 200 pa bo prvotna vrednost 100 samodejno prikazana v celici D2 za snemanje. Pojdite naprej, da spremenite 200 na 300, številka 200 bo vstavljena v celico D3, sprememba 300 na 400 bo prikazala 300 na D4 in tako naprej. Metoda v tem članku vam lahko pomaga, da jo dosežete.

V celico s kodo VBA zabeležite spremenljive vrednosti


V celico s kodo VBA zabeležite spremenljive vrednosti

Spodnja koda VBA vam lahko pomaga zabeležiti vsako spreminjajočo se vrednost v celico v Excelu. Naredite naslednje.

1. Na delovnem listu je celica, v katero želite zapisati spreminjajoče se vrednosti, z desno miškino tipko kliknite jeziček lista in nato kliknite Ogled kode iz kontekstnega menija. Oglejte si posnetek zaslona:

2. Nato Microsoft Visual Basic za aplikacije odpre se okno, kopirajte spodnjo kodo VBA v okno Code.

Koda VBA: beleži spreminjanje vrednosti v celici

Dim xVal As String
'Update by Extendoffice 2018/8/22
Private Sub Worksheet_Change(ByVal Target As Range)
    Static xCount As Integer
    Application.EnableEvents = False
    If Target.Address = Range("C2").Address Then
        Range("D2").Offset(xCount, 0).Value = xVal
        xCount = xCount + 1
    Else
        If xVal <> Range("C2").Value Then
         Range("D2").Offset(xCount, 0).Value = xVal
        xCount = xCount + 1
        End If
    End If
    Application.EnableEvents = True
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    xVal = Range("C2").Value
End Sub

Opombe: V kodi je C2 celica, v katero želite zabeležiti vse njene spreminjajoče se vrednosti. D2 je celica, v katero boste vnesli prvo spreminjajočo se vrednost C2.

3. Pritisnite druga + Q tipke za zapiranje Microsoft Visual Basic za aplikacije okno.

Odslej bodo vsakič, ko spremenite vrednosti v celici C2, prejšnje spreminjajoče se vrednosti zabeležene v D2 in celice pod D2.

Najboljša pisarniška orodja za produktivnost

🤖 Kutools AI Aide: Revolucionirajte analizo podatkov na podlagi: Inteligentna izvedba   |  Ustvari kodo  |  Ustvarite formule po meri  |  Analizirajte podatke in ustvarite grafikone  |  Prikličite funkcije Kutools...
Priljubljene funkcije: Poiščite, označite ali identificirajte dvojnike   |  Izbriši prazne vrstice   |  Združite stolpce ali celice brez izgube podatkov   |   Krog brez formule ...
Super iskanje: Več kriterijev VLookup    Multiple Value VLookup  |   VLookup na več listih   |   Nejasno iskanje ....
Napredni spustni seznam: Hitro ustvarite spustni seznam   |  Odvisni spustni seznam   |  Večkrat izberite spustni seznam ....
Upravitelj stolpcev: Dodajte določeno število stolpcev  |  Premakni stolpce  |  Preklop stanja vidnosti skritih stolpcev  |  Primerjaj obsege in stolpce ...
Predstavljene funkcije: Mrežni fokus   |  Pogled oblikovanja   |   Velika vrstica formule    Upravitelj delovnih zvezkov in listov   |  Knjižnica virov (Samodejno besedilo)   |  Izbirnik datuma   |  Združite delovne liste   |  Šifriranje/dešifriranje celic    Pošljite e-pošto po seznamu   |  Super filter   |   Poseben filter (filter krepko/ležeče/prečrtano ...) ...
15 najboljših kompletov orodij12 Besedilo Orodja (dodajanje besedila, Odstrani znake,...)   |   50 + Graf Vrste (Gantt Chart,...)   |   40+ Praktično Formule (Izračunajte starost glede na rojstni dan,...)   |   19 vstavljanje Orodja (Vstavite kodo QR, Vstavi sliko s poti,...)   |   12 Pretvorba Orodja (Številke v besede, Pretvorba valut,...)   |   7 Spoji in razdeli Orodja (Napredne kombinirane vrstice, Razdeljene celice,...)   |   ... in več

Napolnite svoje Excelove spretnosti s Kutools za Excel in izkusite učinkovitost kot še nikoli prej. Kutools za Excel ponuja več kot 300 naprednih funkcij za povečanje produktivnosti in prihranek časa.  Kliknite tukaj, če želite pridobiti funkcijo, ki jo najbolj potrebujete...

Opis


Kartica Office prinaša vmesnik z zavihki v Office in poenostavi vaše delo

  • Omogočite urejanje in branje z zavihki v Wordu, Excelu, PowerPointu, Publisher, Access, Visio in Project.
  • Odprite in ustvarite več dokumentov v novih zavihkih istega okna in ne v novih oknih.
  • Poveča vašo produktivnost za 50%in vsak dan zmanjša na stotine klikov miške za vas!
Comments (50)
No ratings yet. Be the first to rate!
This comment was minimized by the moderator on the site
Hi,

Not sure if this post is still open but hoping you can help me...

I have a large data set with multiple columns, and rows, that I use for reporting but occasionally I need to overwrite any cell for a restated figure. I need to record the value previously recorded in the cell as an audit trail but it is important this stores every iteration (as shown in your example above). Please may you show me how to edit the script to occur across a range of date (eg. F10:F29, G10:G29, H10:H29... etc). OR... it would be even better if I could use the range as a named workbook - one worksheet includes multiple named and referenced workbooks for my vlookups and indirect formulas. It would also be great if the output was a list of numbers in one cell rather than separate cells down the column (this is not a requirement though)

I read your article "How To Remember Or Save Previous Cell Value Of A Changed Cell In Excel?" which is great, but this does not record every change.

Thanks,
This comment was minimized by the moderator on the site
Hi Saskia,
The following code can help solving your problem.
1) The number 6 in this line "Set xDCell = Cells(xCell.Row, 6)" stands for the sixth column "column F" in the worksheet, where you want to record the previous values. You can change this number 6 to any column number as you need.
2) After adding the VBA code, please go to the Tools tab, click References, and then enable the Microsoft Scripting Runtime box in the References - VBAProject dialog box.
https://www.extendoffice.com/images/stories/comments/comment-picture-zxm/check-scripting_runtime.png
3) Every change will be recorded in one cell.
https://www.extendoffice.com/images/stories/comments/comment-picture-zxm/previous-record.png
Dim xRg As Range
Dim xChangeRg As Range
Dim xDependRg As Range
Dim xDic As New Dictionary
Private Sub Worksheet_Change(ByVal Target As Range)
'Updated by Extendoffice 20221505
    Dim I As Long
    Dim xCell As Range
    Dim xDCell As Range
    Dim xHeader As String
    Dim xCommText As String
    On Error Resume Next
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    xHeader = "Previous value :"
    x = xDic.Keys
    For I = 0 To UBound(xDic.Keys)
        Set xCell = Range(xDic.Keys(I))
        Set xDCell = Cells(xCell.Row, 6)
        If (xDCell.Value = "") Then
            xDCell.Value = xDic.Items(I)
        Else
            xDCell.Value = xDCell.Value & "," & xDic.Items(I)
        End If
        
    Next
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim I, J As Long
    Dim xRgArea As Range
    Dim st As String
    On Error GoTo Label1
    xDic.RemoveAll
    If Target.Count > 1 Then Exit Sub
    Application.EnableEvents = False
    Set xDependRg = Target.Dependents
    If xDependRg Is Nothing Then GoTo Label1
    If Not xDependRg Is Nothing Then
        Set xDependRg = Intersect(xDependRg, Range("C:C"))
    End If
Label1:
    Set xRg = Intersect(Target, Range("C:C"))
    If (Not xRg Is Nothing) And (Not xDependRg Is Nothing) Then
        Set xChangeRg = Union(xRg, xDependRg)
    ElseIf (xRg Is Nothing) And (Not xDependRg Is Nothing) Then
        Set xChangeRg = xDependRg
    ElseIf (Not xRg Is Nothing) And (xDependRg Is Nothing) Then
        Set xChangeRg = xRg
    Else
        Application.EnableEvents = True
        Exit Sub
    End If
    
    For I = 1 To xChangeRg.Areas.Count
        Set xRgArea = xChangeRg.Areas(I)
        For J = 1 To xRgArea.Count
            xDic.Add xRgArea(J).Address, xRgArea(J).Formula
        Next
    Next
    Set xChangeRg = Nothing
    Set xRg = Nothing
    Set xDependRg = Nothing
    Application.EnableEvents = True
End Sub
This comment was minimized by the moderator on the site
This is great! The output into one cell in a list format is exactly what I was hoping for, thank you.

One last question please, is there a way to modify this to look at a table of values instead of a single column (in your example"C:C"). For example, I need to apply the code across several tables: F11:U25, F33:U47... etc. I previously used this script which searches multiple cells for changes that would output onto another tab (I no longer need this, but the output you have provided above):



Private Sub Worksheet_Change(ByVal Target As Range)
Dim KeyCells As Range

' The variable KeyCells contains the cells that will
' cause an alert when they are changed.
Set KeyCells = Range("F11:U25")

If Not Application.Intersect(KeyCells, Range(Target.Address)) _
Is Nothing Then

a = Sheets("Sheet3").Cells(Rows.Count, "A").End(xlUp).Column + 1
ActiveCell.Offset(0, 1).Select
Sheets("Sheet3").Range("A" & a).Value = ActiveCell.Value
ActiveCell.Offset(0, 1).Select
End If
End Sub



Is it possible to combine this with yours?

Thanks, Saskia
This comment was minimized by the moderator on the site
Hi Saskia,
If multiple cells in a table are modified, how do you want to output the previous data? For clarity, please attach a sample file or a screenshot with your data and desired results.
This comment was minimized by the moderator on the site
Merhaba;
Nasılsınız kusura bakmayın derdimi tam olarak anlatamadım özür dilerim.
Aşağıda VBA kodunu beraber yapmıştık. Bu kot olumlu olarak çalışıyor. sadece bunu aynı Excel sayfasında birden fazla kullanmak istiyorum ama nasıl yapacağımı beceremiyorum .
Öncelikle bana cevap verdiğiniz için çok minnettarım tekrardan teşekkürler.
Aslında basit bir sac açılım hesaplamaları içeren bir Excel tablosu hazırlamaya çalışıyorum.
ekteki Excel den görebilirsiniz.
mavi renkli hücreler değişen hücreler ve onların sonuçlarına göre kırmızı hücreler çıkıyor .
bu kırmızı hücrelerdeki sonuçlar panel saç açılımı sonuçları oluyor ben bunları D,F,H,J Hücrelerinde her değişimde alt alta gelecek şekilde ayarlamaya çalışıyorum. her sonuç değiştiğinde (yaptığımız worksheet işe yarıyor ama tek tek sayfa yapmak lazım ama sadece ben kullanmayacağım için tek sayfada aynı işlemleri yapmak çok işimize yarayacak )
Beklide çok daha kolay ve sabit bir çözüm vardır ama ben çözemedim siz çözebilirseniz çok sevinirim .
ekteki Excel de size gönderdiğim worksheet ile sizin yaptığınız kod (aşağıdaki) çalışması yapılmış

Dim xVal As String
'Update by Extendoffice 2022/9/30
Private Sub Worksheet_Change(ByVal Target As Range)
' Static xCount As Integer
Application.EnableEvents = False

xCount = WorksheetFunction.CountA(Range("D:D"))
If Target.Address = Range("C2").Address Then
Range("D2").Offset(xCount, 0).Value = xVal
Else
If xVal <> Range("C2").Value Then
Range("D2").Offset(xCount, 0).Value = xVal
End If
End If
Application.EnableEvents = True
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
xVal = Range("C2").Value
End Sub
This comment was minimized by the moderator on the site
Tekrardan merhaba nasılsınız .
sizden bir yardım daha isteyebilir miyim
yukarda yazdığımız vba kodunu aynı Excel sayfasında 1 den fazla kullanmak istiyorum . Sadece hücrelerini değiştirerek nasıl yaparım her yolu denedim ama beceremedim
yardımcı olursanız sevinirim .
Kolay Gelsin
This comment was minimized by the moderator on the site
Hi Erdal Matpay,
The VBA codes in the following article may do you a favor. Please give it a try.
How To Remember Or Save Previous Cell Value Of A Changed Cell In Excel?
This comment was minimized by the moderator on the site
Hi

Thanks for your answer
I tried today and the result is positive

Regards Best
This comment was minimized by the moderator on the site
merhabalar öncelikle yaptığınız çalışma çok iyi ve emeğinize sağlık.
sizden şöyle bir şey rica edebilir miyim
D2 hücrelerinde çıkan sonuçlar alt alta yazılıyor ama ben D2 hücresinde çıkan bazı sonuçlar yanlış olduğu zaman siliyorum . Ama sildiğim yerden değil de 1 sonraki hücreden devam ediyor. yada komple D2 hücresini sildiğimde baştan değil de kaldığı hücreden devam ediyor . Bunu nasıl çözerim sizin bir fikriniz var mı yardımcı olursanız sevinirim .
Kolay Gelsin
This comment was minimized by the moderator on the site
Hi Erdal matpay,
Sorry I misunderstood you in the first reply. The following code can help.
After removing some records, new records will start from the cells you cleared. Please give it a try.

Dim xVal As String
'Update by Extendoffice 2022/9/30
Private Sub Worksheet_Change(ByVal Target As Range)
'    Static xCount As Integer
    Application.EnableEvents = False
    
    xCount = WorksheetFunction.CountA(Range("D:D"))
    If Target.Address = Range("C2").Address Then
        Range("D2").Offset(xCount, 0).Value = xVal
    Else
        If xVal <> Range("C2").Value Then
         Range("D2").Offset(xCount, 0).Value = xVal
        End If
    End If
    Application.EnableEvents = True
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    xVal = Range("C2").Value
End Sub
This comment was minimized by the moderator on the site
Hi Erdal matpay,
The following VBA code can acheive: when clearing the value in C2, all the records you made before are also cleared together, and the new records will start from cell D2 again. Please give it a try.

Dim xVal As String
'Update by Extendoffice 2022/9/30
Private Sub Worksheet_Change(ByVal Target As Range)
    Static xCount As Integer
    On Error Resume Next
    Application.EnableEvents = False

    If Target.Address = Range("C2").Address Then
        If Range("C2").Value = "" Then
            Range("D2").Resize(xCount, 1).Clear
            xCount = 0
            xVal = ""
            Application.EnableEvents = True
        Exit Sub
    End If
        If xVal <> "" Then
            Range("D2").Offset(xCount, 0).Value = xVal
            xCount = xCount + 1
        End If
    Else
        If xVal <> Range("C2").Value Then
            Range("D2").Offset(xCount, 0).Value = xVal
            xCount = xCount + 1
        End If
    End If
    Application.EnableEvents = True
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    xVal = Range("C2").Value
End Sub
There are no comments posted here yet
Load More
Leave your comments
Posting as Guest
×
Rate this post:
0   Characters
Suggested Locations