CODEWITHSUNDEEP
excelexcel-2003vba
IRHM
IRHM

Reputation: 1326

Track Excel Cell Changes

I wonder whether someone may be able yo help me please.

I'm using the code below to track Excel cell changes with the addition of inserting the text value of "No" in column "G" and the date of cell change in column "A" 

Option Explicit
    Public preValue As Variant
    Private Sub Worksheet_Change(ByVal Target As Range)

        Dim Cell As Range
        If Target.Cells.Count > 1 Then Exit Sub
            On Error Resume Next
            If Not Intersect(Target, Range("B5:H10")) Is Nothing Then
            If Target.Value <> preValue And Target <> "" Then
            Application.EnableEvents = False
            Range("A" & Target.Row).Value = Date
            Range("G" & Target.Row).Value = "No"
            Application.EnableEvents = True
            Target.ClearComments
            Target.AddComment.Text Text:="Previous Value was " & preValue & Chr(10) & "Revised " & Format(Date, "dd-mm-yyyy") & Chr(10) & "By " & Environ("UserName")
            Target.Interior.ColorIndex = 35
        End If
    End If
    On Error GoTo 0
    End Sub

    Private Sub Worksheet_SelectionChange(ByVal Target As Range)

        If Target.Count > 1 Then Exit Sub
        If Target = "" Then
            preValue = "a blank"
        Else: preValue = Target.Value
        End If
        preValue = Target.Value
    End Sub

What I'd like to be able to do is extend this a little further. So if the value in column "G" changes from "No" to "Yes" I'd like all cell shading to be removed from the cells on the same row in columns "B:G", but I'm not sure how to do this.

I just wondered whether someone may be able to look at this please and offer some guidance on how I may go about changing this.

Many thanks and kind regards

Post Edit Working Solution

Option Explicit
Public preValue As Variant
Private Sub Worksheet_Change(ByVal Target As Range)

    Dim cell As Range
    Dim Rng As Range
    If Target.Cells.Count > 1 Then Exit Sub
    On Error Resume Next
    If Not Intersect(Target, Range("B5:W500")) Is Nothing Then
        If Target.Value <> preValue And Target.Value <> "" Then
            Application.EnableEvents = False
            Range("A" & Target.Row).Value = Date
            Range("AX" & Target.Row).Value = "No"
            Application.EnableEvents = True
            'Target.ClearComments
            'Target.AddComment.Text Text:="Previous Value was " & preValue & Chr(10) & "Revised " & Format(Date, "dd-mm-yyyy") & Chr(10) & "By " & Environ("UserName")
            Target.Interior.ColorIndex = 35
        End If
    End If
    On Error GoTo 0
            If Target.Column = 50 Then
                If Target.Value = "Yes" Then
                Set Rng = Application.Union(Cells(ActiveCell.Row, "B").Resize(, 22), Cells(ActiveCell.Row, "W"))
                Rng.Interior.ColorIndex = xlNone
                End If
                End If
End Sub

Upvotes: 0

Views: 854

Answers (1)

IRHM
IRHM

Reputation: 1326

All, after trawling through the internet, I've now got this to work. I've included my solution below. 

Option Explicit
Public preValue As Variant
Private Sub Worksheet_Change(ByVal Target As Range)

    Dim cell As Range
    Dim Rng As Range
    If Target.Cells.Count > 1 Then Exit Sub
    On Error Resume Next
    If Not Intersect(Target, Range("B5:W500")) Is Nothing Then
        If Target.Value <> preValue And Target.Value <> "" Then
            Application.EnableEvents = False
            Range("A" & Target.Row).Value = Date
            Range("AX" & Target.Row).Value = "No"
            Application.EnableEvents = True
            'Target.ClearComments
            'Target.AddComment.Text Text:="Previous Value was " & preValue & Chr(10) & "Revised " & Format(Date, "dd-mm-yyyy") & Chr(10) & "By " & Environ("UserName")
            Target.Interior.ColorIndex = 35
        End If
    End If
    On Error GoTo 0
            If Target.Column = 50 Then
                If Target.Value = "Yes" Then
                Set Rng = Application.Union(Cells(ActiveCell.Row, "B").Resize(, 22), Cells(ActiveCell.Row, "W"))
                Rng.Interior.ColorIndex = xlNone
                End If
                End If
End Sub

Upvotes: 1

Related Questions