Preskoči na glavno vsebino

Kako si zapomniti ali shraniti prejšnjo vrednost celice spremenjene celice v Excelu?

Običajno bo pri posodabljanju celice z novo vsebino prejšnja vrednost pokrita, razen če razveljavite operacijo v Excelu. Če pa želite obdržati prejšnjo vrednost za primerjavo s posodobljeno, bo shranitev prejšnje vrednosti celice v drugo celico ali v komentar celice dobra izbira. Metoda v tem članku vam bo pomagala doseči.

Shranite prejšnjo vrednost celice s kodo VBA v Excelu


Shranite prejšnjo vrednost celice s kodo VBA v Excelu

Recimo, da imate tabelo, kot je prikazano na spodnji sliki zaslona. Če se je katera koli celica v stolpcu C spremenila, želite shraniti njeno prejšnjo vrednost v ustrezno celico stolpca G ali samodejno shraniti v komentar. Za dosego tega naredite naslednje.

1. Na delovnem listu je vrednost, ki jo boste shranili pri posodabljanju, z desno miškino tipko kliknite jeziček lista in izberite Ogled kode v meniju z desnim klikom. Oglejte si posnetek zaslona:

2. Na odprtju Microsoft Visual Basic za aplikacije okno, kopirajte spodnjo kodo VBA v okno Code.

Naslednja koda VBA vam pomaga shraniti prejšnjo vrednost celice določenega stolpca v drug stolpec.

Koda VBA: Shranite vrednost prejšnje celice v drugo celico stolpca

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)
    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, 7)
        xDCell.Value = ""
        xDCell.Value = xDic.Items(I)
    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
    On Error GoTo Label1
    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
    xDic.RemoveAll
    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

Za shranjevanje prejšnje vrednosti celice v komentarju uporabite spodnjo kodo VBA

Koda VBA: Shrani prejšnjo vrednost celice v komentar

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)
    Dim I As Long
    Dim xCell As Range
    Dim xHeader As String
    Dim xCommText As String
    On Error Resume Next
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    xHeader = "Previous value :"
    For I = 0 To UBound(xDic.Keys)
        Set xCell = Range(xDic.Keys(I))
        If Not xCell.Comment Is Nothing Then xCell.Comment.Delete
        With xCell
            .AddComment
            .Comment.Visible = False
            .Comment.Text xHeader & vbCrLf & xDic.Items(I)
        End With
    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
    On Error GoTo Label1
    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
    xDic.RemoveAll
    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).Text
        Next
    Next
    Set xChangeRg = Nothing
    Set xRg = Nothing
    Set xDependRg = Nothing
    Application.EnableEvents = True
End Sub

Opombe: V kodi številka 7 označuje stolpec G, v katerega boste shranili prejšnjo celico, in C: C je stolpec, v katerega boste shranili prejšnjo vrednost celice. Prosimo, spremenite jih glede na vaše potrebe.

3. klik Orodja > Reference da odprete Reference - VBAProject pogovorno okno, preverite Izvajanje Microsoftovih skriptov in na koncu kliknite OK . Oglejte si posnetek zaslona:

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

Od zdaj naprej, ko se vrednost celice v stolpcu C posodobi, se prejšnja vrednost celice shrani v ustrezne celice v stolpcu G ali shrani v komentar, kot je prikazano spodaj.

Shrani prejšnje vrednosti celic v druge celice:

Shranite prejšnje vrednosti celic v komentarje:

Najboljša pisarniška orodja za produktivnost

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

zavihek kte 201905


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 (23)
No ratings yet. Be the first to rate!
This comment was minimized by the moderator on the site
Hi, I'm a newbie of VBA👋

I have a question here 🧐
I pasted the VBA code: Save previous cell value in the comment I my excel but
What if my previous cell is blank then do nothing (No comment) for that particular BLANK cell?
How do I modify the VBA code?
Any expert to provide any solution of this, many thanks👋
This comment was minimized by the moderator on the site
Hi!

Thank you for the function, i would like to know what i have to change to keep all the change.

For exemple if i change two time the value i want te save both last values.

Thank you in advance for the help!
This comment was minimized by the moderator on the site
Hi,
The following VBA code accomplishes this: Track all changes in Column C and store the previous values in successive columns starting from Column G. If Column G is not where you want to start storing these values, adjust the xColumn = 7 line in the code (7 represents Column G, 8 for Column H, and so on).
Hope I can help.

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 20240112
    Dim xCell As Range
    Dim xPrevCell As Range
    Dim xColumn As Long
    On Error Resume Next
    Application.ScreenUpdating = False
    Application.EnableEvents = False

    For Each xCell In Target
        If Not xDic.Exists(xCell.Address) Then GoTo NextCell
        If Intersect(xCell, Me.Range("C:C")) Is Nothing Then GoTo NextCell

        ' Find next available column starting from G
        xColumn = 7
        While Me.Cells(xCell.Row, xColumn).Value <> ""
            xColumn = xColumn + 1
        Wend

        ' Save previous value to the next available column
        Set xPrevCell = Me.Cells(xCell.Row, xColumn)
        xPrevCell.Value = xDic(xCell.Address)

NextCell:
    Next xCell

    ' Clear the dictionary and re-enable events
    xDic.RemoveAll
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    On Error GoTo 0
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim cell As Range
    On Error Resume Next
    Application.EnableEvents = False

    ' Reset dictionary and store current values for cells in column C
    xDic.RemoveAll
    For Each cell In Intersect(Target, Me.Range("C:C"))
        If Not cell Is Nothing Then
            xDic.Add cell.Address, cell.Value
        End If
    Next cell

    Application.EnableEvents = True
    On Error GoTo 0
End Sub
This comment was minimized by the moderator on the site
Can any body help in this problem
This comment was minimized by the moderator on the site
saving the previous data when entering manually but not working when data is refreshing from a web site, it is doing nothing
please help
thanks
This comment was minimized by the moderator on the site
Hi Kamal.
This problem is a bit complicated. After trying various methods, I can't deal with it. I am sorry for that.
This comment was minimized by the moderator on the site
only working when entering data manually
but not working when data is refreshing from a website
please help
thanks
This comment was minimized by the moderator on the site
cho e hỏi chút là có cách nào để khi tính toán cộng trừ xong thì nó sẽ lưu lại giá trị khi tính toán xong không ạ
ví dụ:
Giá trị ở cột A = cột B + cột C
Khi tính toán xong cột A sẽ lưu giá trị sau khi đã tính toán xong, lần tiếp theo tính toán thì nó cột A sẽ lấy giá trị hiện tại để tính toán tiếp chứ không lấy giá trị ban đầu ạ
This comment was minimized by the moderator on the site
Hi trung,
The code has been updated. Please give it a try. Thanks for your feedback.
In the following code, the number 5 in this line Set xDCell = Cells(xCell.Row, 5) represents the column E where you will place the previous value. A:A refers to the cells in column A. You need to save the previous values of these cells.

Dim xRg As Range
'Updated by Extendoffice 20220803
Dim xChangeRg As Range
Dim xDependRg As Range
Dim xDic As New Dictionary
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim I As Long
    Dim xCell As Range
    Dim xDCell As Range
    Dim xHeader As String
    Dim xCommText As String
    Dim X
    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, 5)
        
        xDCell.NumberFormatLocal = xCell.NumberFormatLocal
        xDCell.Value = xDic.Items(I)
        
    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
    On Error GoTo Label1
    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("A:A"))
    End If
Label1:
    Set xRg = Intersect(Target, Range("A:A"))
    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
    xDic.RemoveAll
    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).Text ' 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
It is good if you type in.Can you help me to work it in when data is entered by using the value of function from DDE(Dynamic Data Exchange) as well?
This comment was minimized by the moderator on the site
Hi,
Sorry I can't solve this problem. I suggest you post the problem to the forum below to get help from other Excel enthusiasts.
https://www.extendoffice.com/forum/kutools-for-excel.html
This comment was minimized by the moderator on the site
Is there a way to repeat this for all changes? I would like the Comments Box to show all of the previous entries if possible.
This comment was minimized by the moderator on the site
Hi Jennie! Did you manage to solve this issue? I am also trying to collect in a comments box all the new entries, but I am having difficulties to adapt the VBA code to this. Thank you!
This comment was minimized by the moderator on the site
If the cell I want to save is a formula, the G cell will only save the formula, and calculate the value. I need to save the value - not the formula. How can I tell the VBA code, that the value changes although the formula is not changed. Best regards Flemming
This comment was minimized by the moderator on the site
This is for one cell value ,but how do for multiple cell value ,i want 4 cell data store and update like this for example C,D,E,F cell data into G,H,I,J cell respectively ,how can do please help
There are no comments posted here yet
Load More
Please leave your comments in English
Posting as Guest
×
Rate this post:
0   Characters
Suggested Locations