Salt la conținutul principal

Cum să numărăm de câte ori o celulă este schimbată în Excel?

Pentru a număra de câte ori o celulă specificată este schimbată în Excel, codurile VBA furnizate în acest articol vă pot ajuta.

Numărați de câte ori o celulă este schimbată cu codul VBA

Numărați de câte ori o celulă este schimbată cu codul VBA

Următoarele coduri VBA vă pot ajuta să numărați de câte ori o celulă specificată este schimbată în Excel.

1. În foaia de lucru care conține una sau mai multe celule pentru care trebuie să calculați modificarea totală, faceți clic dreapta pe fila foii, apoi faceți clic pe Afișați codul din meniul contextual. Vedeți captura de ecran:

2. În deschidere Microsoft Visual Basic pentru aplicații fereastra, copiați și inserați unul dintre următoarele coduri VBA în Cod fereastră în funcție de nevoile dvs.

Cod VBA 1: Urmăriți modificările la o singură celulă

Dim xCount As Integer
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim xRg As Range, xCell As Range
    On Error Resume Next
    If Target = Range("B9") Then
        xCount = xCount + 1
        Range("C9").Value = xCount                                     
    End If
    Application.EnableEvents = False
    Set xRg = Application.Intersect(Target.Dependents, Me.Range("B9"))
    If Not xRg Is Nothing Then
        xCount = xCount + 1
        Range("C9").Value = xCount
    End If
    Application.EnableEvents = True
End Sub

notițe: În cod, B9 este celula de care aveți nevoie pentru a număra modificările sale, iar C9 este celula pentru a completa rezultatul numărării. Vă rugăm să le schimbați după cum aveți nevoie.

Cod VBA 2: Urmăriți modificările la mai multe celule dintr-o coloană

Private Sub Worksheet_Change(ByVal Target As Range)
'Updated by Extendoffice 20220916
    Dim xSRg As Range
    Dim xRRg As Range
    
    Set xSRg = Range("B9:B1000")
    Set xCell = Intersect(xSRg, Target)
    If xCell Is Nothing Then Exit Sub
    
    
    Application.EnableEvents = False
    On Error Resume Next
    Set xCell = xCell.Range("A1")
    Set xRRg = xCell.Offset(0, 1)
    
    xRRg.Value = xRRg.Value + 1

    Application.EnableEvents = True
End Sub

notițe: În această linie "Setați xRRg = xCell.Offset(0, 1)", numarul 1 reprezintă numărul de coloane de compensat la dreapta referinței de pornire (aici referința de pornire este coloana B, iar numărul pe care doriți să-l returnați este în coloană C care se localizează lângă coloana B). Dacă trebuie să afișați rezultatele în coloană S, schimbați numărul 1 la 10.

De acum înainte, când se modifică celula B9 sau orice celulă din intervalul B9:B1000, numărul total de modificări va fi suprapus și completat automat în celula specificată.

Cele mai bune instrumente de productivitate de birou

🤖 Kutools AI Aide: Revoluționați analiza datelor pe baza: Execuție inteligentă   |  Generați codul  |  Creați formule personalizate  |  Analizați datele și generați diagrame  |  Invocați funcțiile Kutools...
Caracteristici populare: Găsiți, evidențiați sau identificați duplicatele   |  Ștergeți rândurile goale   |  Combinați coloane sau celule fără a pierde date   |   Rundă fără Formula ...
Super căutare: VLookup cu mai multe criterii  |   VLookup cu valori multiple  |   VLookup pe mai multe foi   |   Căutare fuzzy ....
Listă derulantă avansată: Creați rapid o listă derulantă   |  Listă drop-down dependentă   |  Listă derulantă cu selectare multiplă ....
Manager de coloane: Adăugați un număr specific de coloane  |  Mutați coloanele  |  Comutați starea vizibilității coloanelor ascunse  |  Comparați intervale și coloane ...
Caracteristici prezentate: Focus pe grilă   |  Vedere de proiectare   |   Big Formula Bar   |  Manager registru de lucru și foi   |  Biblioteca de resurse (Text automat)   |  Data Picker   |  Combinați foi de lucru   |  Criptare/Decriptare celule   |  Trimiteți e-mailuri după listă   |  Super Filtru   |   Filtru special (filtrează bold/italic/barat...) ...
Top 15 seturi de instrumente:  12 Text Instrumente (Adăuga text, Eliminați caractere,...)   |   50+ Diagramă Tipuri de (Gantt Chart,...)   |   40+ Practic Formule (Calculați vârsta pe baza zilei de naștere,...)   |   19 inserare Instrumente (Introduceți codul QR, Inserați imaginea din cale,...)   |   12 Convertire Instrumente (Numere la cuvinte, conversie valutara,...)   |   7 Merge & Split Instrumente (Rânduri combinate avansate, Celule divizate,...)   |   ... și altele

Îmbunătățiți-vă abilitățile Excel cu Kutools pentru Excel și experimentați eficiența ca niciodată. Kutools pentru Excel oferă peste 300 de funcții avansate pentru a crește productivitatea și a economisi timp.  Faceți clic aici pentru a obține funcția de care aveți cea mai mare nevoie...

Descriere

Fila Office aduce interfața cu file în Office și vă face munca mult mai ușoară

  • Activați editarea și citirea cu file în Word, Excel, PowerPoint, Publisher, Access, Visio și Project.
  • Deschideți și creați mai multe documente în filele noi ale aceleiași ferestre, mai degrabă decât în ​​ferestrele noi.
  • Vă crește productivitatea cu 50% și reduce sute de clicuri de mouse pentru dvs. în fiecare zi!
Comments (26)
No ratings yet. Be the first to rate!
Graham
Graham
This comment was minimized by the moderator on the site
Hi, is there a way to apply this across multiple ranges?

I want to monitor say Column B changes offset into C (as this code does) but then also Monitor Column D changes offset into E
Reply
0
0
crystal
crystal     Graham
This comment was minimized by the moderator on the site
Hi Graham,

The following VBA code can do you a favor. Please give it a try.
Note: You can change the ranges in the code to suityour own data range.

Private Sub Worksheet_Change(ByVal Target As Range)
    'Updated by Extendoffice 20240119
    Dim xSRgB As Range
    Dim xSRgD As Range
    Dim xCell As Range
    Dim xRRg As Range
    
    ' Define the source ranges for columns B and D
    Set xSRgB = Range("B9:B1000")
    Set xSRgD = Range("D9:D1000")

    ' Check if the changed cell is in either of the defined ranges
    Set xCell = Nothing
    If Not Intersect(xSRgB, Target) Is Nothing Then
        Set xCell = Intersect(xSRgB, Target)
        Set xRRg = xCell.Offset(0, 1) ' Offset to column C
    ElseIf Not Intersect(xSRgD, Target) Is Nothing Then
        Set xCell = Intersect(xSRgD, Target)
        Set xRRg = xCell.Offset(0, 1) ' Offset to column E
    End If

    If xCell Is Nothing Then Exit Sub

    Application.EnableEvents = False
    On Error Resume Next
    
    ' Update the adjacent cell with the change count
    xRRg.Value = xRRg.Value + 1

    Application.EnableEvents = True
    On Error GoTo 0
End Sub
Reply
Report
0
0
Jaydee
Jaydee
This comment was minimized by the moderator on the site
Hi Crystal,

the below code does not work if a cell is dynamically being updated by another VBScript. I have a cell that is being populated by a VBScript and wanted to count the number of times the cell is updating but your code is not capturing the change.

Dim xCount As Integer
Private Sub Worksheet_Change(ByVal Target As Range)
Dim xRg As Range, xCell As Range
On Error Resume Next
If Target = Range("B9") Then
xCount = xCount + 1
Range("C9").Value = xCount
End If
Application.EnableEvents = False
Set xRg = Application.Intersect(Target.Dependents, Me.Range("B9"))
If Not xRg Is Nothing Then
xCount = xCount + 1
Range("C9").Value = xCount
End If
Application.EnableEvents = True
End Sub

here is my code:
Sub Button11_Click()

Worksheets("C4L1").Range("A2:R35").Calculate
With Worksheets("C4L1")
Range("M2").Calculate
Range("N2").Calculate
Range("O2").Calculate
Range("P2").Calculate
Range("Q2").Calculate
Range("R2").Calculate
End With

End Sub

Thanks
Vgee
Reply
Report
0
0
crystal
crystal     Jaydee
This comment was minimized by the moderator on the site
Hi Vgee,

I can't get the Excel Worksheet_Change event capture the changes caused by another VBScript. Sorry for the inconvenience.
Reply
Report
0
0
wagner cesar
wagner cesar
This comment was minimized by the moderator on the site
Olá Cristal,

vi que você tem ajudado o pessoal com código vba. será q vc poderia me dar uma ajuda tb?

eu tenho uma coluna B e C onde eu preencho cada uma delas diariamente... o que eu gostaria de saber é quantas vezes eu mudo o campo B2 até mudar o campo C2 e manter esse valor de alterações no campo D2

exemplo: eu alterei o campo B2 5 vezes seguidas ate alterar o C2

D2 = 5

e quantas vezes eu alterei o campo C2 até voltar a alterar B2
exemplo: alterei o campo C2 2 vezes seguidas e voltei a alterar o campo B2
E2 = 2

e eu gostaria de manter o valor máximo dessa sequência, só voltando a alterar o campo D2 e E2 se a sequencia de alterações em B2 e C2 fossem maior do que 5 e 2, como no exemplo que eu dei.

espero que tenha ficado claro os exemplos. ahahhah... abraços
Reply
0
0
crystal
crystal     wagner cesar
This comment was minimized by the moderator on the site
Hi wagner cesar,
The following VBA code may help. Please give it a try. Thank you.

Private Sub Worksheet_Change(ByVal Target As Range)
'Updated by Extendoffice 20220916
    Dim xSRg As Range
    Dim xRRg As Range
    On Error Resume Next
    
    Set xSRg = Range("B2:B10")
    Set xCell = Intersect(xSRg, Target)
    If Not xCell Is Nothing Then
        Application.EnableEvents = False
        Set xCell = xCell.Range("A1")
        Set xRRg = xCell.Offset(0, 2)
        xRRg.Value = xRRg.Value + 1
        If xRRg.Value > 5 Then
            xRRg.Value = 1
        End If
        Application.EnableEvents = True
    End If
    
    Set xSRg = Range("C2:C10")
    Set xCell = Intersect(xSRg, Target)
    If Not xCell Is Nothing Then
        Application.EnableEvents = False
        Set xCell = xCell.Range("A1")
        Set xRRg = xCell.Offset(0, 2)
        xRRg.Value = xRRg.Value + 1
        If xRRg.Value > 2 Then
            xRRg.Value = 1
        End If
        Application.EnableEvents = True
    End If
        
End Sub
Reply
Report
0
0
Julian
Julian
This comment was minimized by the moderator on the site
Thanks Crystal, works great!
Reply
0
0
I try
I try
This comment was minimized by the moderator on the site
I try the code below and it works, but I'm using it to track changes on dates, since some dates are the same everytime I change a date that is the same to other on the colum it count again.
I try the latest code but it does nothing when I try it. THANKS FOR THIS GREAT CODE!

Private Sub Worksheet_Change(ByVal Target As Range)
Dim xRg As Range, xCell As Range
Dim xSRg, xRRg As Range
Dim xFNum As Long

Set xSRg = Range("I3:I1000")
Set xRRg = Range("S3:S1000")

Application.EnableEvents = False
On Error Resume Next
For xFNum = 1 To xSRg.Count
If Target = xSRg.Item(xFNum) Then
xRRg.Item(xFNum).Value = xRRg.Item(xFNum).Value + 1
Application.EnableEvents = True
Exit Sub
End If
Next xFNum
Application.EnableEvents = True
End Sub
Sub CleaRCount()
'Updated by Extendoffice 20220527
xCount = 0
Range("S3") = 0
End Sub
Reply
0
0
crystal
crystal     I try
This comment was minimized by the moderator on the site
Hi,
The following VBA code can do you a favor. Please give it a try.
Note: In this line "Set xRRg = xCell.Offset(0, 10)", the number "10” represents the number of columns to offset to the right of the starting reference (here the starting reference is column I, and the count you want to return is in column S).

Private Sub Worksheet_Change(ByVal Target As Range)
'Updated by Extendoffice 20220919
    Dim xSRg As Range
    Dim xRRg As Range
    
    Set xSRg = Range("I3:I1000")
    Set xCell = Intersect(xSRg, Target)
    If xCell Is Nothing Then Exit Sub
    
    
    Application.EnableEvents = False
    On Error Resume Next
    Set xCell = xCell.Range("A1")
    Set xRRg = xCell.Offset(0, 10)
    
    xRRg.Value = xRRg.Value + 1

    Application.EnableEvents = True
End Sub
Reply
Report
0
0
Gadjus
Gadjus
This comment was minimized by the moderator on the site
Hi Crystal

I am having the same issue as RedDragon. I am trying to track date changes, for example when an agent sends a case to their manager they manually enter a date- this can happen more than once On a case so I am trying to use this code to show how many times each case has been sent to a manager. My issues are:

1) If multiple cases are sent to managers in one day, the counter increases only on the first instance of that date, not next to the rows in question.
2) Every time I exit the sheet, reopen it, and amend a date, the counter resets to "1"- how would I get this to carry over and not reset when the sheet is reopened?

Any help is greatly appreciated and thank you so much for what you have done so far.

Gadjus
Reply
0
0
crystal
crystal     Gadjus
This comment was minimized by the moderator on the site
Hi Gadjus,
Sorry for the inconvinience. The following VBA code can do you a favor. Please give it a try.

Private Sub Worksheet_Change(ByVal Target As Range)
'Updated by Extendoffice 20220916
    Dim xSRg As Range
    Dim xRRg As Range
    
    Set xSRg = Range("B9:B1000")
    Set xCell = Intersect(xSRg, Target)
    If xCell Is Nothing Then Exit Sub
    
    
    Application.EnableEvents = False
    On Error Resume Next
    Set xCell = xCell.Range("A1")
    Set xRRg = xCell.Offset(0, 1)
    
    xRRg.Value = xRRg.Value + 1

    Application.EnableEvents = True
End Sub
Reply
Report
0
0
FMARINO
FMARINO
This comment was minimized by the moderator on the site
Quisiera que me ayudaran a reiniciar el contador a cero cuando lo requiera, es decir, la celda c9 llevarla a cero y comenzar a contar b9 nuevamente.
Reply
Report
0
0
crystal
crystal     FMARINO
This comment was minimized by the moderator on the site
Hi FELIX MARIÑO,
Please add the following code after the code provided in this post. When you need to reset the cell, click on any words in the code, and then press the F5 key to run it.
Sub CleaRCount()
'Updated by Extendoffice 20220527
    xCount = 0
    Range("c9") = 0
End Sub
Reply
Report
0
0
Mason
Mason
This comment was minimized by the moderator on the site
Can anyone help me achieve the coding for Counting the time a cell has been changed to "Revalidate" and can that be applied down the entrieity of a column.
Reply
0
0
JediTrader
JediTrader
This comment was minimized by the moderator on the site
Team,

When I tried using :

Private Sub Worksheet_Change(ByVal Target As Range)
Dim xRg As Range, xCell As Range
Dim xSRg, xRRg As Range
Dim xFNum As Long

Set xSRg = Range("B9:B1000")
Set xRRg = Range("C9:C1000")

carefully changing the Range and Target cells vis a vis P2:P200 and X2:X200 respectively, I dont the change-count in X Column despite myself trying to change cells across multiple rows across P2:P200.

Any help would be greatly appreciated.

Regards
JT
Reply
Report
0
0
cherias
cherias
This comment was minimized by the moderator on the site
Hello All,

The solution as provided under "Count Number Of Times A Cell Is Changed With VBA Code" is good if we are only tracking changes to ONE CELL. Please suggest, what modifications are needed, if the tracking is to be done for multiple cells. In case of multiple cells, the incremental counter should appear next to the cell for which the change in value is being tracked.
Reply
Report
0
0
Shiju
Shiju     cherias
This comment was minimized by the moderator on the site
Looking forward for help and assistance to have a specific VBA code, which can be applied to multiple cells in one worksheet.
Reply
0
0
crystal
crystal     Shiju
This comment was minimized by the moderator on the site
Hi Shiju,
Please try the below VBA code. Thanks for commenting.

Private Sub Worksheet_Change(ByVal Target As Range)
Dim xRg As Range, xCell As Range
Dim xSRg, xRRg As Range
Dim xFNum As Long

Set xSRg = Range("B9:B1000")
Set xRRg = Range("C9:C1000")

Application.EnableEvents = False
On Error Resume Next
For xFNum = 1 To xSRg.count
If Target = xSRg.Item(xFNum) Then
xRRg.Item(xFNum).Value = xRRg.Item(xFNum).Value + 1
Application.EnableEvents = True
Exit Sub
End If
Next xFNum
Application.EnableEvents = True
End Sub
Reply
Report
0
0
There are no comments posted here yet
Load More
Please leave your comments in English
Guest
Posting as Guest
×
Rate this post:
Reset
0   Characters
Suggested Locations