Hiệu ứng nhấp nháy (2 người xem)

Liên hệ QC

Người dùng đang xem chủ đề này

Đang trực tuyến: 1 (Thành viên: 0, Khách: 1)
Tôi tuân thủ nội quy khi đăng bài
Có
V

vanquyenmrt123

Thành viên mới
Tham gia
11/11/21
Bài viết
12
Được thích
0
Mình muốn làm nhấp nháy trong ô "A1", (nhấp nháy chữ hoặc số trong ô) nhấp nháy 2 cái rồi tắt thôi, chứ không nhấp nháy liên tục. Xin các cao nhân giúp đỡ với ạ!
 
Làm đại. Tần suất 1s, màu chữ thay đổi từ đen-trắng-đen-trắng
Mã: 
Option Explicit
Sub nhapnhay()
Dim i&
With Range("A1").Font
Do
    i = i + 1
    Application.Wait Now + TimeSerial(0, 0, 1) ' Thoi gian nhap nhay la 1s
    .Color = vbBlack ' chu mau den
    Application.Wait Now + TimeSerial(0, 0, 1)
    .Color = vbWhite ' chu mau trang
Loop Until i = 2 ' so lan nhap nhay
End With
End Sub
 

File đính kèm

Bạn có thể sử dụng Hàm Flick dưới đây:

Chỉ cần gõ =Flick(B1)
Hoặc gõ biểu thức vào trong =Flick(SUM(A1,B1,C1))

Giá trị ở ô tham chiếu thay đổi tự động nhấp nháy.

Các tham số:
1. Value - Tham chiếu ô hoặc biểu thức​
2. Color - Màu sẽ thay đổi​
3. Times - Số lần đổi màu​
4. DelayTime - khoản thời gian đổi màu (đơn vị mili giây)​
5. FlickBackground - Đổi màu nền​

Để kích hoạt nhấp nháy sử dụng phương thức Dirty, ví dụ ô A1 gõ Flick, mã sẽ là:
JavaScript: 
Sub OnFlick()
    [A1].Dirty
End Sub

***Lưu ý:
1. Hàm này không khuyến khích sử dụng vì nó sẽ làm mất đi chế độ Undo và Redo trang tính.
2. Khi sửa thay đổi trang tính hoặc VBA hãy bật chế độ Design Mode, để hàm không bị kích hoạt.

Chép mã vào một Module mới
JavaScript: 
Option Explicit
Option Compare Text
#If VBA7 = 0 Then
  Private Enum LongLong:[_]:End Enum
  Private Enum LongPtr:[_]:End Enum
#End If
#If -VBA7 And -Win64 Then
  Private Declare PtrSafe Function SetTimer Lib "USER32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr, ByVal uElapse As LongPtr, ByVal lpTimerFunc As LongPtr) As LongPtr
  Private Declare PtrSafe Function KillTimer Lib "USER32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr) As LongPtr
#ElseIf VBA7 Then
  Private Declare PtrSafe Function SetTimer Lib "USER32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr, ByVal uElapse As LongPtr, ByVal lpTimerFunc As LongPtr) As Long
  Private Declare PtrSafe Function KillTimer Lib "USER32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr) As Long
#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
#End If
Private Type TypeArguments
  Action As Long
  Timer As Single
  ThisCell As Object
  addr As String
  Fx As String
  RSTarget As Range
  color1 As Long
  color2 As Long
  delay As Single
  Timer2 As Single
  Timer3 As Single
  FlickBackground As Boolean
  BGNone As Boolean
  DisplayColor1 As Long
  DisplayColor2 As Long
  NumberFormat As String
  ColorFormat As String
  FormatCondition As Object
End Type

Private Works() As TypeArguments, cltWorks As Collection

Private Sub FlickTest()
  On Error Resume Next
  Static b%: b = b + 1
  Select Case b Mod 3
  Case 0: [D2].Resize(3).value = 0
  Case 1: [D2].Resize(3).value = -1
  Case 2: [D2].Resize(3).value = 1
  End Select
  Cells.SpecialCells(xlCellTypeFormulas).Dirty
End Sub

Function Flick(value As Variant, Optional Color = vbRed, Optional times& = 5, Optional delaytime& = 250, Optional FlickBackground As Boolean)
  Flick = value
  On Error Resume Next
  Dim r As Object, k%, j&, f$, s$, n As Boolean, vs&, a

  Set r = Application.caller: f = r.Formula: s = r.Address(0, 0, , 1)
  If r Is Nothing Then Exit Function
  If cltWorks Is Nothing Then
    Set cltWorks = New Collection: GoSub ne
  Else
    k = cltWorks(s): If k = 0 Then GoSub ne Else Exit Function
  End If
  times = IIf(times < 1, 1, IIf(times > 20, 20, times))
  delaytime = IIf(delaytime < 200, 200, IIf(delaytime > 2000, 2000, delaytime))
  With Works(k)
    If FlickBackground Then .color1 = r.Interior.Color Else .color1 = r.Font.Color
    .delay = delaytime / 1000
    .Timer2 = Timer
    .Timer3 = Timer + (times + 3) * .delay + 0.5
    .FlickBackground = FlickBackground
    Color = Localize_SetColor(Color)
    .color2 = IIf(.color1 = Color, vbGreen, Color)
  End With
  SetTimer Application.hwnd, 55126126, 50, AddressOf Flick_Working
E:
Exit Function
ne:
  k = UBound(Works): k = k + 1: ReDim Preserve Works(1 To k): cltWorks.Add k, s
  With Works(k): .Action = 1: Set .ThisCell = r: .addr = s: .Fx = f: .Timer = Timer:
  End With
Return
End Function

Private Function colorInNumberFormat(ByVal NumberFormat$, ByVal colorIndex%) As String
  Dim a, i%, j%, k%, l%, s$, d%, v$
  a = Array("[Black]", "[White]", "[Red]", "[Green]", "[Blue]", "[Yellow]", "[Cyan]", "[Magenta]")
  For i = -7 To 56
    If i <= 0 Then
      s = a(i + 7): GoSub a
    Else
      s = "[Color " & i & "]": GoSub a
    End If
  Next
Exit Function
a:
  k = InStr(1, NumberFormat, s, 1)
  If k Then
    If colorIndex = i Then
      l = Len(NumberFormat)
      For i = k + Len(s) To l
        v = Mid$(NumberFormat, i, 1)
        Select Case d
        Case 0:
          Select Case v
          Case "[": d = 1
          Case Else: d = 2: j = i: If i = l Then colorInNumberFormat = Mid$(NumberFormat, i): Exit Function
          End Select
        Case 1: If v = "]" Then d = 2: j = i + 1
        Case 2:
          If v = ";" Or i = l Then
            l = IIf(v = ";", i - j, l - j + 1)
            colorInNumberFormat = Mid$(NumberFormat, j, l): Exit Function
          End If
        End Select
      Next
    End If
  End If
Return
End Function
Private Sub Flick_Working(ByVal hwnd As LongPtr, ByVal wMsg As LongPtr, ByVal idEvent As LongPtr, ByVal dwTime As LongPtr)
  On Error Resume Next
  Dim i, k%, ash As Object, b As TypeArguments, n As Boolean, c&, r As Range, s$
  Dim fm As FormatCondition
  Set ash = Application.ActiveSheet
  For Each i In cltWorks
    With Works(i): b = Works(i)
      Select Case .Action
      Case 1, 2: n = True: Set r = .ThisCell
        If .Action = 1 Then
          .Action = 2
          .BGNone = r.DisplayFormat.Interior.Pattern = xlNone
          .DisplayColor1 = r.DisplayFormat.Font.Color
          .DisplayColor2 = r.DisplayFormat.Interior.Color
          s = r.NumberFormat: .NumberFormat = s:
          If s Like "*[[]*]*" Then
            s = colorInNumberFormat(s, r.DisplayFormat.Font.colorIndex)
            If s <> "" Then .ColorFormat = s:
          End If
          If .ColorFormat = "" Then
            For Each fm In r.FormatConditions
              If .FlickBackground Then
                Err.Clear: c = fm.Interior.Color
                If Err = 0 Then If c = .DisplayColor2 Then Set .FormatCondition = fm: .color1 = c: Exit For
              Else
                Err.Clear: c = fm.Font.Color
                If Err = 0 Then If c = .DisplayColor1 Then Set .FormatCondition = fm: .color1 = c: Exit For
              End If
            Next
            If Not .FormatCondition Is Nothing Then .BGNone = .FormatCondition.Interior.Pattern = xlNone
          End If
        End If
        DoEvents
        If ash Is r.Parent Then
          If Timer >= .Timer2 Then
            .Timer2 = .Timer2 + .delay
            If .ColorFormat <> "" And Not .FlickBackground Then
              r.NumberFormat = IIf(r.NumberFormat = .ColorFormat, .NumberFormat, .ColorFormat)
            Else
              If .FormatCondition Is Nothing Then
                If .FlickBackground Then
                  With r.Interior
                    .Color = IIf(.Color = b.color1, b.color2, b.color1)
                  End With
                Else
                  With r.Font
                    .Color = IIf(.Color = b.color1, b.color2, b.color1)
                  End With
                End If
              Else
                If .FlickBackground Then
                  With .FormatCondition.Interior
                      .Color = IIf(.Color = b.color1, b.color2, b.color1)
                  End With
                Else
                  Err.Clear
                  With .FormatCondition.Font
                    .Color = IIf(.Color = b.color1, b.color2, b.color1)
                  End With
                End If
              End If
            End If
          End If
        Else
          GoTo r
        End If
        If Timer > .Timer3 Then
r:
          .Action = 3:
          If .ColorFormat <> "" And Not .FlickBackground Then
            r.NumberFormat = .NumberFormat
          Else
            If .FormatCondition Is Nothing Then
              If .FlickBackground Then
                If .BGNone Then
                  r.Interior.Pattern = xlNone
                Else
                  r.Interior.Color = b.color1
                End If
              Else
                r.Font.Color = b.color1
              End If
            Else
              If .FlickBackground Then
                If .BGNone Then
                  .FormatCondition.Interior.Pattern = xlNone
                Else
                  .FormatCondition.Interior.Color = b.color1
                End If
              Else
                .FormatCondition.Font.Color = b.color1
              End If
            End If
          End If
        End If
      End Select
    End With
  Next
E:
  If Not n Then
    Set cltWorks = Nothing
    Erase Works
    KillTimer hwnd, idEvent
  End If
End Sub
Sub colors56()
  Application.ScreenUpdating = False
  Application.Calculation = xlCalculationManual
  Dim i As Long
  Dim str0 As String, str As String
  For i = 1 To 55
    Cells(i, 1).Interior.colorIndex = i
    Cells(i, 1).value = "[Color " & i & "]"
    Cells(i, 2).Font.colorIndex = i
    Cells(i, 2).value = "[Color " & i & "]"
    str0 = Right("000000" & Hex(Cells(i, 1).Interior.Color), 6)
    str = Right(str0, 2) & Mid(str0, 3, 2) & Left(str0, 2)

    Cells(i, 3) = "#" & str
    Cells(i, 4).Formula = "=Hex2dec(""" & Right(str0, 2) & """)"
    Cells(i, 5).Formula = "=Hex2dec(""" & Mid(str0, 3, 2) & """)"
    Cells(i, 6).Formula = "=Hex2dec(""" & Left(str0, 2) & """)"
    Cells(i, 7) = "[Color " & i & "]"
  Next i
done:
  Application.Calculation = xlCalculationAutomatic
  Application.ScreenUpdating = True
End Sub

Private Function Localize_SetColor(ByVal Color As String) As Long
  Dim v As Long
  Select Case Color
  Case "yellow", "ye", "yl": v = vbYellow
  Case "red", "re": v = vbRed
  Case "blue": v = vbBlue
  Case "green", "gr": v = vbGreen
  Case "cyan", "cy": v = vbCyan
  Case "magenta", "ma": v = vbMagenta
  Case "white", "wh", "wi": v = vbWhite
  Case "black", "bl", "bk": v = vbBlack
  Case "orange", "or": v = &H71AFFF
  Case "pink": v = &HE819E8
  Case "purple", "pu": v = &HB44343
  Case "silver", "si": v = &HCBCBCB
  Case "violet", "vi": v = &HF5A2BF
  Case "Brown", "br": v = &H3232AA
  Case "Beige", "be": v = &HE819E8
  Case Else
    Select Case True
    Case Color Like "*[a-fA-F]*"
      If Color Like "[#]*" Then Color = Mid(Color, 2)
      Color = Mid(Color, 5, 2) & Mid(Color, 3, 2) & Mid(Color, 1, 2)
      v = CLng(IIf(Color Like "&H*", "", "&H") & Color)
    Case IsNumeric(Color): v = CLng(Color)
    Case Else: v = vbBlue
    End Select
  End Select
  Localize_SetColor = v
End Function
 

File đính kèm

Lần chỉnh sửa cuối:
HeSanbi đã viết:
Bạn có thể sử dụng Hàm Flick dưới đây:

Chỉ cần gõ =Flick(B1)
Hoặc gõ biểu thức vào trong =Flick(SUM(A1,B1,C1))

Giá trị ở ô tham chiếu thay đổi tự động nhấp nháy.

Các tham số:
1. Value - Tham chiếu ô hoặc biểu thức​
2. Color - Màu sẽ thay đổi​
3. Times - Số lần đổi màu​
4. DelayTime - khoản thời gian đổi màu (đơn vị mili giây)​
5. FlickBackground - Đổi màu nền​

Để kích hoạt nhấp nháy sử dụng phương thức Dirty, ví dụ ô A1 gõ Flick, mã sẽ là:
JavaScript: 
Sub OnFlick()
    [A1].Dirty
End Sub


Chép mã vào một Module mới
JavaScript: 
Option Explicit
#If VBA7 = 0 Then
  Private Enum LongLong:[_]:End Enum
  Private Enum LongPtr:[_]:End Enum
#End If
#If -VBA7 And -Win64 Then
  Private Declare PtrSafe Function SetTimer Lib "USER32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr, ByVal uElapse As LongPtr, ByVal lpTimerFunc As LongPtr) As LongPtr
  Private Declare PtrSafe Function KillTimer Lib "USER32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr) As LongPtr
#ElseIf VBA7 Then
  Private Declare PtrSafe Function SetTimer Lib "USER32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr, ByVal uElapse As LongPtr, ByVal lpTimerFunc As LongPtr) As Long
  Private Declare PtrSafe Function KillTimer Lib "USER32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr) As Long
#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
#End If
Private Type TypeArguments
  Action As Long
  Timer As Single
  ThisCell As Object
  addr As String
  Fx As String
  RSTarget As Range
  color1 As Long
  color2 As Long
  delay As Long
  Timer2 As Single
  Timer3 As Single
  FlickBackground As Boolean
End Type

Private Works() As TypeArguments, cltWorks As Collection

Function Flick(value As Variant, Optional color& = vbRed, Optional times& = 5, Optional delaytime& = 500, Optional FlickBackground As Boolean)
  Flick = value
  On Error Resume Next
  Dim R As Object, k%, i%, j%, f$, s$, n As Boolean, vs&, a, bk As Object, it
  Set bk = ThisWorkbook
  Set R = Application.caller: f = R.Formula: s = R.Address(0, 0, , 1): Set bk = R.Parent.Parent

  If cltWorks Is Nothing Then
    Set cltWorks = New Collection: GoSub ne
  Else
    k = cltWorks(s): If k = 0 Then GoSub ne
  End If
  times = IIf(times < 1, 1, IIf(times > 20, 20, times))
  delaytime = IIf(delaytime < 200, 200, IIf(delaytime > 2000, 2000, delaytime))
  With Works(k)
    If FlickBackground Then .color1 = R.Interior.color Else .color1 = R.Font.color
    .color2 = IIf(.color1 = color, vbGreen, color)
    .delay = delaytime
    .Timer2 = Timer
    .Timer3 = Timer + (times * delaytime) / 1000
    .FlickBackground = FlickBackground
  End With
  SetTimer Application.hwnd, 55126126, 100, AddressOf Flick_Working
E:
Exit Function
ne:
  k = UBound(Works): k = k + 1: ReDim Preserve Works(1 To k): cltWorks.Add k, s
  With Works(k): .Action = 1: Set .ThisCell = R: .addr = s: .Fx = f: .Timer = Timer:
  End With
Return
End Function

Private Sub Flick_Working(ByVal hwnd As LongPtr, ByVal wMsg As LongPtr, ByVal idEvent As LongPtr, ByVal dwTime As LongPtr)
  On Error Resume Next
  Dim i, k%, ash As Object, b As TypeArguments, n As Boolean
  Set ash = Application.ActiveSheet
  For Each i In cltWorks
    With Works(i): b = Works(i)
      Select Case .Action
      Case 1: n = True
        If ash Is .ThisCell.Parent And Timer >= .Timer2 Then
          .Timer2 = .Timer2 + .delay / 1000
          If .FlickBackground Then
            With .ThisCell.Interior
              .color = IIf(.color = b.color1, b.color2, b.color1)
            End With
          Else
            With .ThisCell.Font
              .color = IIf(.color = b.color1, b.color2, b.color1)
            End With
          End If
        End If
        If Timer > .Timer3 Then
          .Action = 2:
          If .FlickBackground Then
            .ThisCell.Interior.color = b.color1
          Else
            .ThisCell.Font.color = b.color1
          End If
        End If
      End Select
    End With
  Next
E:
  If Not n Then
    Set cltWorks = Nothing
    Erase Works
    KillTimer hwnd, idEvent
  End If
End Sub
Nhấp chuột vào đây để mở rộng...
Bác chia sẻ phương pháp tổng quát giải quyết vấn đề tạo function với các trường hợp không bình thường như kiểu tạo thêm 1 hiệu ứng kèm với hàm như thế này được không ạ?
 
bebo021999 đã viết:
Làm đại. Tần suất 1s, màu chữ thay đổi từ đen-trắng-đen-trắng
Mã: 
Option Explicit
Sub nhapnhay()
Dim i&
With Range("A1").Font
Do
    i = i + 1
    Application.Wait Now + TimeSerial(0, 0, 1) ' Thoi gian nhap nhay la 1s
    .Color = vbBlack ' chu mau den
    Application.Wait Now + TimeSerial(0, 0, 1)
    .Color = vbWhite ' chu mau trang
Loop Until i = 2 ' so lan nhap nhay
End With
End Sub
Nhấp chuột vào đây để mở rộng...
thanks bạn, nhưng nhờ bạn thêm 1 tí được không, ở ô A1 (mình random giá trị bất và dùng conditional formating để định dạng, giá trị âm sẽ bôi đỏ). Giờ mình chỉ muốn nhấp nháy giá trị đó lên (dạng nhấn mạnh kết quả), và mình nhấp nháy giá trị theo màu của kết quả đó luôn (vi dụ giá trị âm màu đỏ thì nhấp nháy màu đỏ ấy, và giảm thời gian nhấp nháy còn 0.25s)
Mình đòi hỏi hơi nhiều nhưng lỡ nhờ giúp thì mình nhờ luôn, bạn thông cảm, hihi. Chúc bạn sức khỏe!
 

File đính kèm

vanquyenmrt123 đã viết:
thanks bạn, nhưng nhờ bạn thêm 1 tí được không, ở ô A1 (mình random giá trị bất và dùng conditional formating để định dạng, giá trị âm sẽ bôi đỏ). Giờ mình chỉ muốn nhấp nháy giá trị đó lên (dạng nhấn mạnh kết quả), và mình nhấp nháy giá trị theo màu của kết quả đó luôn (vi dụ giá trị âm màu đỏ thì nhấp nháy màu đỏ ấy, và giảm thời gian nhấp nháy còn 0.25s)
Mình đòi hỏi hơi nhiều nhưng lỡ nhờ giúp thì mình nhờ luôn, bạn thông cảm, hihi. Chúc bạn sức khỏe!
Nhấp chuột vào đây để mở rộng...
Trong thực tế, ô A1 của bạn là kết quả từ công thức (như trong file, là randbetween) hay là bạn nhập tay vào?
Vì nếu nhập tay, mình sẽ tạo event cho ô A1 và tự động nhấp nháy
Nếu là công thức, bạn hãy post công thức lên để xem có cài tự động nhấp nháy khi giá trị thay đổi được hay không, nếu không thì phải dùng subroutine và nút nhấn để kích hoạt code.
 
VBA mình chỉ áp dụng cho tối thiểu 1s nhé. Nếu ít hơn thì xem dùng "kernel32" library (code bài #3).

Đoạn code dưới đây sẽ chuyển đổi format ô giữa dạng ";;;" (visible) và "General" (invisible), sẽ không làm thay đổi màu text mà chỉ hide nó đi thôi.
thời gian: t=1s
Không tự động chạy mà phải vào sub để chạy.

Mã: 
Option Explicit
Sub nhapnhay()
Dim i&
Const t = 1 ' thoi gian cho la 1s
Const freq = 3 ' so lan nhap nhay
With Range("A1")
    Do
        i = i + 1
        Application.Wait Now + TimeSerial(0, 0, t)
        .NumberFormat = ";;;" ' set o A1 to invisible
        Application.Wait Now + TimeSerial(0, 0, t)
        .NumberFormat = "General" ' set o A1 to visible
        If i >= freq And .NumberFormat = "General" Then Exit Sub
    Loop
End With
End Sub
 
bebo021999 đã viết:
VBA mình chỉ áp dụng cho tối thiểu 1s nhé. Nếu ít hơn thì xem dùng "kernel32" library (code bài #3).

Đoạn code dưới đây sẽ chuyển đổi format ô giữa dạng ";;;" (visible) và "General" (invisible), sẽ không làm thay đổi màu text mà chỉ hide nó đi thôi.
thời gian: t=1s
Không tự động chạy mà phải vào sub để chạy.

Mã: 
Option Explicit
Sub nhapnhay()
Dim i&
Const t = 1 ' thoi gian cho la 1s
Const freq = 3 ' so lan nhap nhay
With Range("A1")
    Do
        i = i + 1
        Application.Wait Now + TimeSerial(0, 0, t)
        .NumberFormat = ";;;" ' set o A1 to invisible
        Application.Wait Now + TimeSerial(0, 0, t)
        .NumberFormat = "General" ' set o A1 to visible
        If i >= freq And .NumberFormat = "General" Then Exit Sub
    Loop
End With
End Sub
Nhấp chuột vào đây để mở rộng...
Mình cam ơn bạn nhiều nha!
 
Tôi đã thêm mã cho cả FormatNumber và Format Conditions, bạn có thể thử lại bài #3
 
vanquyenmrt123 đã viết:
Hiện tại ô D2 bạn đang set giá trị cố định, vậy chỗ ô D2 nó chạy theo công thức riêng của mình thì sao ạ, công thức của mình áp vào nó sẽ ra giá trị bất kỳ (âm,0, dương)
Nhấp chuột vào đây để mở rộng...

Thủ tục đó là một ví dụ, bạn sử dụng thì bạn tùy biến. Tất cả nằm ở hàm Flick mà thôi, bạn nhập gì vào hàm thì hàm sẽ chạy. phương thức Dirty chỉ là tính toán lại ô
 
HeSanbi đã viết:
Thủ tục đó là một ví dụ, bạn sử dụng thì bạn tùy biến. Tất cả nằm ở hàm Flick mà thôi, bạn nhập gì vào hàm thì hàm sẽ chạy. phương thức Dirty chỉ là tính toán lại ô
Nhấp chuột vào đây để mở rộng...
Cảm ơn bạn, mình đã hiểu rồi, cảm ơn bạn nhiều ạ!
 

File đính kèm

  • 1700809270779.png
    1700809270779.png
    16.4 KB · Đọc: 5
HeSanbi đã viết:
Thủ tục đó là một ví dụ, bạn sử dụng thì bạn tùy biến. Tất cả nằm ở hàm Flick mà thôi, bạn nhập gì vào hàm thì hàm sẽ chạy. phương thức Dirty chỉ là tính toán lại ô
Nhấp chuột vào đây để mở rộng...
bạn cho mình hỏi thêm tí, mình muốn đổi màu nền (FlickBackground - Đổi màu nền), (hiện tại bạn đang làm màu tím), mình nhìn đống code ko biết chỗ nào vô chỗ nào, hì
 
vanquyenmrt123 đã viết:
bạn cho mình hỏi thêm tí, mình muốn đổi màu nền (FlickBackground - Đổi màu nền), (hiện tại bạn đang làm màu tím), mình nhìn đống code ko biết chỗ nào vô chỗ nào, hì
Nhấp chuột vào đây để mở rộng...
Bạn chỉ cần code như thế này thôi.
Code trong Worksheet:
Mã: 
Private Sub Worksheet_Calculate()
    SheetCalculate
End Sub
Code trong Module:
Mã: 
#If VBA7 Then
    Private Declare PtrSafe Function SetTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr, ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As LongPtr
    Private Declare PtrSafe Function KillTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr) As LongPtr
    Private T 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 T As Long
#End If
Private lColor As Long
Const sCll As String = "A1"
Const lFlickColor As Long = vbCyan
Const ms As Long = 250
Const lTime As Long = 2
Sub SheetCalculate()
    If lColor = 0 Then lColor = Sheet1.Range(sCll).Interior.Color
    ResetTimer
    T = SetTimer(0, 0, ms, AddressOf DoFlick)
End Sub
Private Sub DoFlick()
    Static k As Long
    With Sheet1.Range(sCll)
        If .Interior.Color = lColor Then
            .Interior.Color = lFlickColor
            k = k + 1
        Else
            .Interior.Color = lColor
            If k = lTime Then
                k = 0
                ResetTimer
            End If
        End If
    End With
End Sub
Private Sub ResetTimer()
    T = KillTimer(0, T)
    Sheet1.Range(sCll).Interior.Color = lColor
End Sub
 

File đính kèm

vanquyenmrt123 đã viết:
bạn cho mình hỏi thêm tí, mình muốn đổi màu nền (FlickBackground - Đổi màu nền), (hiện tại bạn đang làm màu tím), mình nhìn đống code ko biết chỗ nào vô chỗ nào, hì
Nhấp chuột vào đây để mở rộng...

Mã tôi đã sửa để bạn dễ dàng đặt màu hơn

Ví dụ đổi màu đỏ: =Flick(B1,"#FF",,,True)

#FF và #0000FF là như nhau

Tên màu tiếng Anh: =Flick(B1,"Red",,,True)

Trong bảng chọn màu:

1700827936219.png
 
Lần chỉnh sửa cuối:
huuthang_bd đã viết:
Bạn chỉ cần code như thế này thôi.
Code trong Worksheet:
Mã: 
Private Sub Worksheet_Calculate()
    SheetCalculate
End Sub
Code trong Module:
Mã: 
#If VBA7 Then
    Private Declare PtrSafe Function SetTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr, ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As LongPtr
    Private Declare PtrSafe Function KillTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr) As LongPtr
    Private T 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 T As Long
#End If
Private lColor As Long
Const sCll As String = "A1"
Const lFlickColor As Long = vbCyan
Const ms As Long = 250
Const lTime As Long = 2
Sub SheetCalculate()
    If lColor = 0 Then lColor = Sheet1.Range(sCll).Interior.Color
    ResetTimer
    T = SetTimer(0, 0, ms, AddressOf DoFlick)
End Sub
Private Sub DoFlick()
    Static k As Long
    With Sheet1.Range(sCll)
        If .Interior.Color = lColor Then
            .Interior.Color = lFlickColor
            k = k + 1
        Else
            .Interior.Color = lColor
            If k = lTime Then
                k = 0
                ResetTimer
            End If
        End If
    End With
End Sub
Private Sub ResetTimer()
    T = KillTimer(0, T)
    Sheet1.Range(sCll).Interior.Color = lColor
End Sub
Nhấp chuột vào đây để mở rộng...
Mình cảm ơn bạn nha!
 
Bạn phải đăng nhập hoặc đăng ký để trả lời bài viết tại đây.
Web KT

Bài viết mới nhất

G
Xin Code xóa Module. (3 người xem)
Trả lời
4
Đọc
100
PhanTuHuong
PhanTuHuong
D
  • Question Question
Quản lý email outlook qua VBA cần giúp đỡ
Trả lời
12
Đọc
224
nguyendang95
N
PhanTuHuong
Sách Lập trình VBA trong AutoCAD đã có mặt
    • Thích
    • Yêu thích
2
Trả lời
21
Đọc
1K
PhanTuHuong
PhanTuHuong
L
Lỗi font khi convert từ pdf (1 người xem)
Trả lời
3
Đọc
118
lamvu0677
L
N
Khắc phục lỗi "The picture is too large and will be truncated"
Trả lời
9
Đọc
5K
SonBDND
S
GPE-Trợ Lý
[GPE] TALKSHOW: PHÂN TÍCH BÁO CÁO ĐỘ NHẠY SỬ DỤNG EXCEL SOLVER (1 người xem)
    • Thích
Trả lời
0
Đọc
218
GPE-Trợ Lý
GPE-Trợ Lý
K
  • Question Question
nhờ ace giúp đỡ tự động filter và In hàng loạt từng mục trong piviot table
Trả lời
1
Đọc
89
khkkh
K
K
Xin dax tính tỷ trọng doanh thu
Trả lời
18
Đọc
764
SteveNguyen1991
S
F
  • Question Question
Tự động Merge Mail bằng VBA
Trả lời
6
Đọc
191
Hoàng Tuấn 868
H
N
Một ví dụ về XLL add-in: Tương tác với Google Gemini dưới dạng công thức bảng tính
    • Thích
Trả lời
0
Đọc
96
nguyendang95
N
H
Nhờ anh/chị giúp đỡ em viết công thức trừ dữ liệu theo FiFo
Trả lời
1
Đọc
102
HieuCD
H
BNTT
LockXLS - Chương trình bảo vệ an toàn cho các file bảng tính Excel
    • Thích
4 5 6
Trả lời
118
Đọc
73K
YêuCN
Y
vsitcnh
Hỗ trợ công thức tính điểm dựa theo điều kiện.
Trả lời
14
Đọc
198
thuytrangbp28
T
micam111
  • Question Question
Cách chạy nhiều đồng hồ đếm giờ trong VBA
Trả lời
4
Đọc
694
thuytrangbp28
T
B
Xin giải pháp chống sửa, xóa dữ liệu đã nhập vào từ ngày hôm trước.
    • Thích
2
Trả lời
26
Đọc
7K
Tuấn Bụng Bự
Tuấn Bụng Bự
Emyeuexcel
  • Question Question
In tất cả các file trong cùng 1 thư mục
Trả lời
3
Đọc
208
Hoàng Tuấn 868
H
1
Hỏi về đánh dấu hàng ngang hàng dọc bằng màu khi kích chuột vào 1 ô
Trả lời
7
Đọc
202
Gà Công Nghệ
Gà Công Nghệ
P
Excell code vba : Tìm Cell để sửa dữ liệu
    • Buồn
2
Trả lời
26
Đọc
579
Phạm Trường 80
P
D
Nhờ anh em giúp đỡ.
    • Buồn
Trả lời
2
Đọc
93
SA_DQ
SA_DQ
00029591
Cần hỗ trợ công thức tổng hợp dữ liệu không cần cột phụ Vlookup
Trả lời
2
Đọc
102
DeTong
D
Xem thêm…

Thành viên có số lượng bài viết cao nhất tháng

Thành viên có điểm tương tác cao nhất tháng

Đếm ngược thời gian

000
Ngày
00
Giờ
00
phút
00
giây
TALK SHOW: CÙNG NHẢY LAM BA ĐA VỚI HÀM LAMBDA (λ) EXCEL 365
Back
Top Bottom