Excel VBA监听单元格背景色改变事件

熟悉Excel的朋友都知道Excel有一个条件格式功能,当单元格值满足预设条件时,自动套用单元格格式。但是如果反过来需要根据单元格格式(尤其是单元格颜色)来改变单元格值时,该怎么做呢?

事实上,目前并没有一个简单的方案来满足这个需求,我们需要通过VBA宏来实现。

首先,需要将“开发工具”激活以使用VBA。在Excel选项的“自定义功能区”中,勾选“开发工具”。

在工具栏中会多出开发工具标签

点击Visual Basic,打开VBA界面。右击VBAProject,选择“插入” – “类模块”

选择该模块,在下方的属性中将名称修改为C_CellColorChange

双击该模块,粘贴以下代码:

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
Code language: VBScript (vbscript)

双击ThisWorkbook,粘贴以下代码:

Option Explicit Private oCellColorMonitor As C_CellColorChange Private Sub Workbook_BeforeClose(Cancel As Boolean) Call StopWatching End Sub Private Sub Workbook_Open() Call StartWatching(ActiveSheet) End Sub Private Sub Workbook_SheetActivate(ByVal Sh As Object) Call StartWatching(Sh) End Sub Public Sub CellColorChanged(Cell As Range, PrevColor As Variant, NewColor As Variant, Cancel As Boolean) MsgBox (NewColor) End Sub Private Sub StartWatching(ByVal Sh As Object) Set oCellColorMonitor = New C_CellColorChange oCellColorMonitor.ApplyToSheet Sh oCellColorMonitor.StartWatching End Sub Private Sub StopWatching() Set oCellColorMonitor = Nothing End Sub
Code language: VBScript (vbscript)

回到Excel,现在当我们更改任意一个单元格背景色的时候,都会提示背景色的颜色值

现在,我们就可以根据自己的需求来扩展脚本了。比如,当单元格颜色为黑色时,值为-1;当颜色为红色时,值为1。只需要修改ThisWorkbook的代码中的CellColorChanged函数即可:

Public Sub CellColorChanged(cell As Range, PrevColor As Variant, NewColor As Variant, Cancel As Boolean) Select Case NewColor Case "0": '黑色|Black cell.Value = -1 Case "255": '红色|Red cell.Value = 1 Case Else '其他颜色则值为0|undefined color, set value to 0 cell.Value = 0 End Select End Sub
Code language: VBScript (vbscript)
%d 博主赞过: