Lập trình VBA nâng cao: Hàm bắt sự kiện giá trị ô thay đổi và tô màu

[HeSanbi]

BẮT SỰ KIỆN GIÁ TRỊ Ô THAY ĐỔI VÀ TÔ MÀU
với Hàm S_EventHL

Hướng dẫn sử dụng hàm:
Tham số :

Vị trí	Tham số	Kiểu	Optional	Diễn giải
1​	Target	Ô		Ô bắt sự kiện đổi (1 ô duy nhất)
2​	Colors	Màu hoặc Mảng màu		Những màu tô cho chuỗi đã tìm thấy (Mảng thì ForecolorDefault phải là 0)
3​	ForecolorDefault	Màu		Màu tô nếu không tìm thấy, nếu để là 0 thì không làm gì cả
4​	Wait	Số nguyên	1500	Đợi hoàn lại màu (Đơn vị mili giây)
5​	Title	Chuỗi	Rỗng	Chuỗi trả về cho Ô nhập công thức (Không cần thiết)

Cách viết hàm nhanh, gõ vào ô chuỗi =S_EventHL và ấn tổ hợp phím Ctrl+Shift+A

Viết đầy đủ để bắt sự kiện ô A1:
=S_EventHL(A1, 355,0,1500)
Mảng màu:
=S_EventHL(A1, {355,460},0,1500)
=S_EventHL(A1, $B$1:$B$10,0,1500)

Lưu ý: Để sử dụng được Hàm S_EventHL trong dự án mới, hãy sao chép module mS_EventHighlight

Hình ảnh:
---------------------------------------------





Mã VBA:
---------------------------------------------

'                    _,
' ___   _   _  _ ___(_)
'/ __| / \ | \| | _ | |
'\__ \/ \ \| \\ | _ \ |
'|___/_/ \_|_|\_|___/_|
'
Option Explicit
#If VBA7 And Win64 Then
    Private Declare PtrSafe Function SetTimer Lib "user32" (ByVal hWnd As LongPtr, ByVal nIDEvent As LongPtr, ByVal uElapse As LongLong, ByVal lpTimerFunc As LongPtr) As LongLong
    Private Declare PtrSafe Function KillTimer Lib "user32" (ByVal hWnd As LongPtr, ByVal nIDEvent As LongPtr) As LongLong
    Private gTimerID^, gTimerID2^
#ElseIf VBA7 Then
    Private Declare PtrSafe Function SetTimer Lib "user32" (ByVal hWnd As LongPtr, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As LongPtr
    Private Declare PtrSafe Function KillTimer Lib "user32" (ByVal hWnd As LongPtr, ByVal nIDEvent As Long) As Long
    Private gTimerID As LongPtr, gTimerID2 As LongPtr
#Else
    Private Declare Function SetTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
    Private Declare Function KillTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long
    Private gTimerID As Long, gTimerID2 As Long
#End If

Private Args(), DArgs As Object
Private Timeout As Date

Sub S_EventHL_test()
  Static i&
  i = i + 1
  [E5] = i
  If i < 5 Then
    Timeout = Now + TimeSerial(0, 0, 2)
    Application.OnTime Timeout, "'" & ThisWorkbook.Name & "'!S_EventHL_test"
  Else
    i = 0
  End If
End Sub
Sub S_EventHL_test_finish()
  On Error Resume Next
  Application.OnTime Timeout, "'" & ThisWorkbook.Name & "'!S_EventHL_test", , False
End Sub
Function S_EventHL(Optional ByVal Target As Range, _
                   Optional ByVal Colors = vbGreen, _
                   Optional ByVal ForecolorDefault& = vbCyan, _
                   Optional ByVal Wait& = 1500, _
                   Optional ByVal Title As String) As Variant
  Wait = Switch(Wait < 400, 400, Wait > 5000, 5000, 1, Wait)
 
  On Error Resume Next
  Dim K As Integer, R, s$, a, b
  Set R = Application.Caller
  s = R(1, 1).Formula
  If Title <> "" Then
    S_EventHL = Title
  Else
    S_EventHL = Mid(s, 2)
  End If
  If Target.Cells.Count > 1 Then GoTo E

  K = UBound(Args)
 
  s = R.Parent.Name & "!" & R.Address & s
  If K > 0 Then
    For Each a In Args
      If s = a(0) And a(1) = 0 Then GoTo E
    Next
  End If

  ReDim Preserve Args(1 To K + 1)
 
  Args(K + 1) = VBA.Array(s, 0, Target, Colors, ForecolorDefault, Wait)

  If gTimerID = 0 Then gTimerID = SetTimer(0&, 0&, 1, AddressOf S_EventHL_callback)
E:
End Function


Private Sub S_EventHL_callback()
  On Error Resume Next
  Call KillTimer(0&, gTimerID): gTimerID = 0
  S_EventHL_callback2
  On Error GoTo 0
End Sub
#If VBA7 And Win64 Then
Public Sub S_EventHL_erase(ByVal hWnd As LongPtr, ByVal wMsg^, ByVal idEvent As LongPtr, ByVal dwTime^)
#ElseIf VBA7 Then
Public Sub S_EventHL_erase(ByVal hWnd As LongPtr, ByVal wMsg&, ByVal idEvent As LongPtr, ByVal dwTime&)
#Else
Public Sub S_EventHL_erase(ByVal hWnd&, ByVal wMsg&, ByVal idEvent&, ByVal dwTime&)
#End If
  On Error Resume Next
    KillTimer 0&, idEvent
    Dim a, i&
    i = UBound(Args)
    If Not DArgs Is Nothing Then
      If DArgs.exists(CStr(idEvent)) Then
        a = DArgs(CStr(idEvent))
        If a(4) <> 0 Then
          If a(2).Parent Is ThisWorkbook.ActiveSheet Then
            a(2).Characters(start:=1, Length:=Len(a(2).value)).Font.color = a(4)
          End If
        End If
        DArgs.Remove CStr(idEvent)
      End If
      If DArgs.Count = 0 Then
        Set DArgs = Nothing
      End If
    End If
  On Error GoTo 0
End Sub



Private Sub S_EventHL_callback2()
  On Error Resume Next
  Dim UA&, i&
  UA = UBound(Args)
  Dim a, R, s$, C, Colors, color&, M, FS(), K&, O, b As Boolean

  For i = 1 To UA
    a = Args(i)
    If a(1) = 0 Then
      Set R = a(2)
      s = R.value
      If s = vbNullString Then GoTo E1
      b = True
      Colors = a(3)
      Select Case TypeName(Colors)
      Case "Range", "Variant()"
        For Each M In Colors
          If IsNumeric(M) Then
            K = K + 1
            ReDim Preserve FS(1 To K): FS(K) = M
          End If
        Next
        Colors = FS
      Case Else: Colors = Array(vbWhite, Colors)
      End Select
      Set O = R.Characters(start:=1, Length:=Len(s)).Font
      If a(4) <> 0 Then O.color = a(4)
      C = O.color
      For K = 1 To UBound(Colors)
        If Colors(K) = C Then
          K = K + 1
          Exit For
        End If
      Next
      If K > UBound(Colors) Then K = 1
      O.color = Colors(K)
      If R.Parent Is ThisWorkbook.ActiveSheet Then
        gTimerID2 = SetTimer(0&, 0&, CLng(a(5)), AddressOf S_EventHL_erase)
        If DArgs Is Nothing Then
          Set DArgs = VBA.CreateObject("Scripting.Dictionary")
        End If
        Args(i)(1) = 1
        DArgs(CStr(gTimerID2)) = a
      End If
      Exit For
    End If
E1:
  Next
E2:
  If b Then
    gTimerID = SetTimer(0&, 0&, 1, AddressOf S_EventHL_callback)
  Else
    Erase Args
  End If
  On Error GoTo 0
End Sub

 

[thukhon2014]

Link die bạn ơi !