Code modification - Log Cell colour change

Drawleeh

New Member
Joined
Sep 2, 2021
Messages
34
Office Version
  1. 2016
  2. 2010
Platform
  1. Windows
Hello, I have found some code on this very forum (Capturing cell color change in VBA) that logs when cell colour is changed on a separate worksheet. How do I adjust that same code so instead of prompting for every single cell it would only prompt once and record the row number instead of cell. Address?

Class module code as follows - labelled C_CellColorChange

VBA Code:
Option Explicit
Private WithEvents cmb As Office.CommandBars
Private bCancel As Boolean
Private bAllCellsCounted As Boolean
Private vCellCurColor() As Variant
Private vCellPrevColor() As Variant
Private sCellAddrss() As String
Private sVisbRngAddr As String
Private i As Long
Private oSh As Worksheet
Private oCell As Range

Public Sub ApplyToSheet(Sh As Worksheet)
    Set oSh = Sh
End Sub

Public Sub StartWatching()
    Set cmb = Application.CommandBars
End Sub

Private Sub Class_Initialize()
    bAllCellsCounted = False
End Sub


Private Sub cmb_OnUpdate()

    If Not ActiveSheet Is oSh Then Exit Sub
    bCancel = False
    i = -1
VisibleRngChanged:
    If sVisbRngAddr <> ActiveWindow.VisibleRange.Address _
        And sVisbRngAddr <> "" Then
        Erase sCellAddrss
        Erase vCellCurColor
        Erase vCellPrevColor
        sVisbRngAddr = ""
        bAllCellsCounted = False
        GoTo VisibleRngChanged
    End If
    On Error Resume Next
        For Each oCell In ActiveWindow.VisibleRange.Cells
            ReDim Preserve sCellAddrss(i + 1)
            ReDim Preserve vCellCurColor(i + 1)
            sCellAddrss(i + 1) = oCell.Address
            vCellCurColor(i + 1) = oCell.Interior.Color
            If vCellPrevColor(i + 1) <> vCellCurColor(i + 1) Then
                If bAllCellsCounted = True Then
                    oCell.Interior.Color = vCellPrevColor(i + 1)
                    CallByName ThisWorkbook, _
                    "CellColorChanged", VbMethod, oCell, _
                    oCell.Interior.Color, vCellCurColor(i + 1), bCancel
                    If Not bCancel Then
                        oCell.Interior.Color = vCellCurColor(i + 1)
                        vCellPrevColor(i + 1) = vCellCurColor(i + 1)
                    Else
                        oCell.Interior.Color = vCellPrevColor(i + 1)
                        vCellCurColor(i + 1) = vCellPrevColor(i + 1)
                    End If
                    bCancel = False
                End If
            End If
                i = i + 1
            If i + 1 >= ActiveWindow.VisibleRange.Cells.Count Then
                bAllCellsCounted = True
                ReDim Preserve vCellPrevColor(UBound(vCellCurColor))
                vCellPrevColor = vCellCurColor
            End If
            vCellPrevColor(i + 1) = vCellCurColor(i + 1)
        Next
    On Error GoTo 0
        sVisbRngAddr = ActiveWindow.VisibleRange.Address

End Sub

And the workbook change event as this:

VBA Code:
Option Explicit
Private oCellColorMonitor As C_CellColorChange

Private Sub Workbook_BeforeClose(Cancel As Boolean)
    Call StopWatching
End Sub

Private Sub Workbook_Open()
    Call StartWatching
End Sub

Public Sub CellColorChanged(Cell As Range, PrevColor As Variant, NewColor As Variant, Cancel As Boolean)
    
    Const MSG1 As String = "Complete Job?"
    
    If MsgBox(MSG1 & vbNewLine, vbQuestion + vbYesNo) _
    = vbNo Then
        Cancel = True
    Else
        With Sheets("Log")
            .Cells(1, 1).End(xlDown).Offset(1) = Format(Date, "dd/mm/yyyy")
            .Cells(1, 2).End(xlDown).Offset(1) = Environ("Username")
        End With
    End If

End Sub


Private Sub StartWatching()
    Set oCellColorMonitor = New C_CellColorChange
    oCellColorMonitor.ApplyToSheet Sheets(1)
    oCellColorMonitor.StartWatching
End Sub

Private Sub StopWatching()
    Set oCellColorMonitor = Nothing
End Sub
 

Excel Facts

Can you AutoAverage in Excel?
There is a drop-down next to the AutoSum symbol. Open the drop-down to choose AVERAGE, COUNT, MAX, or MIN

Forum statistics

Threads
1,223,231
Messages
6,170,884
Members
452,364
Latest member
springate

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top