vb监测Excel两个单元格变化,达到阈值响铃

发布于:2025-06-10 ⋅ 阅读:(17) ⋅ 点赞:(0)

需求

在Excel中实现监控两个单元格之间的变化范围,当达到某个设定的值的范围内时,实现自动响铃提示。

实现:

  1. 首先设置Excel,开启宏、打开开发者工具,点击visual Basic按钮,然后在左侧双击需要监测的sheet。
  2. 此时会打开一个代码编辑窗口,在窗口中粘贴代码,修改需要监控的单元格,然后保存。
  3. 将响铃用的wav格式文件放入到D盘,以下以D盘为例,可自定义。
  4. 此时回到Excel页面然后在对应的单元格编辑数字进行测试。
  5. 以下代码实现了A1到B10这一组范围的多个单元格对,当有一个有变化达到条件时即可出发响铃。
Private Declare PtrSafe Function PlaySound Lib "winmm.dll" Alias "PlaySoundA" _
    (ByVal pszSound As String, ByVal hmod As Long, ByVal fdwSound As Long) As Long

' 常量定义
Private Const SND_ASYNC = &H1        ' 异步播放(后台播放)
Private Const SND_FILENAME = &H20000 ' 参数是文件名
Private Const SND_NODEFAULT = &H2    ' 找不到文件时不播放默认声音

' 模块级变量,用于记录已触发过的行和对应的值
Private triggeredRows As Object

Private Sub Worksheet_Activate()
    ' 初始化字典,在工作表激活时执行一次
    If triggeredRows Is Nothing Then
        Set triggeredRows = CreateObject("Scripting.Dictionary")
    End If
End Sub

Private Sub Worksheet_Calculate()
    Dim i As Long
    Dim threshold As Double
    Dim soundFile As String
    Dim valA As Variant, valB As Variant
    Dim diff As Double
    Dim key As String
    Dim currentHash As String
    
    ' 设置参数
    threshold = 2                   ' 阈值
    soundFile = "D:\xm3555.wav"     ' WAV 文件路径

    ' 初始化 Dictionary
    If triggeredRows Is Nothing Then Set triggeredRows = CreateObject("Scripting.Dictionary")

    ' 遍历每一行
    For i = 1 To 10
        valA = Range("A" & i).Value
        valB = Range("B" & i).Value
        
        ' 确保都是数字
        If IsNumeric(valA) And IsNumeric(valB) Then
            diff = Abs(valA - valB)
            
            ' 构造唯一标识符(当前 A 和 B 的值组合)
            currentHash = valA & "|" & valB
            
            key = "Row" & i
            
            ' 如果这一行没有触发过,或者值发生了变化
            If Not triggeredRows.Exists(key) Or triggeredRows(key) <> currentHash Then
                If diff < threshold Then
                    ' 播放声音
                    If Dir(soundFile) <> "" Then
                        PlaySound soundFile, 0, SND_ASYNC Or SND_FILENAME Or SND_NODEFAULT
                    Else
                        MsgBox "警告音文件未找到: " & soundFile, vbExclamation
                        PlaySound vbNullString, 0, SND_ASYNC
                    End If
                    
                    ' 更新记录为当前值
                    triggeredRows(key) = currentHash
                Else
                    ' 差值不小于阈值,则清除该行记录(可选)
                    If triggeredRows.Exists(key) Then
                        triggeredRows.Remove key
                    End If
                End If
            End If
        End If
    Next i
End Sub