Come posso estendere una macro che mi indichi l'ultima modifica di una cella su più celle?

Question

Buongiorno,

come posso estendere una macro che mi indichi l'ultima modifica di una cella su più celle?

La macro è la seguente:

Private Sub Worksheet_Change(ByVal Target As Range)

CheckArea = "E2"     '<<< Area da tenere sotto controllo

Track = "D2"            '<<< Cella dove scrive data/Ora

If Application.Intersect(Target, Range(CheckArea)) Is Nothing Then Exit Sub

Application.EnableEvents = False

Range(Track).Value = Now()

Application.EnableEvents = True

End Sub

E la tabella dove replicare la macro è questa:

In pratica se modifico la cella E2 mi si aggiorna la "data1" nella cella D2.

Come faccio ad estendere questa macro su ogni "coppia di celle"? Quindi modifico la E3 e si aggiorna la data nella D3 e così via fino in basso per tutte le righe, modifico la H2 e si aggiorna la data della G2, modifico la H3 e si aggiorna la data nella G3 e così su tutta la tabella.

Grazie mille in anticipo

Answer 1

Ciao Luca,

come posso estendere una macro che mi indichi l'ultima modifica di una cella su più celle?

La macro è la seguente:

Private Sub Worksheet_Change(ByVal Target As Range)

CheckArea = "E2"     '<<< Area da tenere sotto controllo

Track = "D2"            '<<< Cella dove scrive data/Ora

If Application.Intersect(Target, Range(CheckArea)) Is Nothing Then Exit Sub

Application.EnableEvents = False

Range(Track).Value = Now()

Application.EnableEvents = True

End Sub

E la tabella dove replicare la macro è questa:

In pratica se modifico la cella E2 mi si aggiorna la "data1" nella cella D2.

Come faccio ad estendere questa macro su ogni "coppia di celle"? Quindi modifico la E3 e si aggiorna la data nella D3 e così via fino in basso per tutte le righe, modifico la H2 e si aggiorna la data della G2, modifico la H3 e si aggiorna la data nella G3 e così su tutta la tabella.

Prova qualcosa del genere:

'=========>>

Option Explicit

'--------->>

Private Sub Worksheet_Change(ByVal Target As Range)

    Dim rTrack As Range, rCell As Range

    Const sTrack = "D:D,G:G,J:J,M:M,P:P,S:S,V:V,Y:Y"

    Set rTrack = Intersect(Me.Range(sTrack), Target)

    If Not rTrack Is Nothing Then

        On Error GoTo XIT

        Application.EnableEvents = False

        For Each rCell In rTrack.Cells

            rCell(1, 2).Value = Now

        Next rCell

    End If

XIT:

    Application.EnableEvents = True

End Sub

'<<=========

Potresti scaricare il mio file di prova Luca20200206.xlsm

===

Regards,

Norman