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

Elx 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.

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

B
  • Question Question
Thiết lập code VBA để đổi tên sheet tự động theo ngày và sao chép hàm tự động
    • Cười
Trả lời
1
Đọc
16
SA_DQ
SA_DQ
C
Fix lỗi Application.InputBox Type:=8 (2 người xem)
    • Cười
Trả lời
7
Đọc
138
SA_DQ
SA_DQ
A
  • Question Question
Sửa code VBA nhập liệu userform (1 người xem)
Trả lời
25
Đọc
1K
Mr.hieudoanxd
Mr.hieudoanxd
ongke0711
  • Question Question
Tải hóa đơn điện tử (https://hoadondientu.gdt.gov.vn/) Excel Vba (8 người xem)
    • Thích
    • Yêu thích
    • Cảm ơn
4 5 6
Trả lời
556
Đọc
72K
sát thủ uyên ương
S
Emyeuexcel
Tham chiếu về 1 ô-lấy ra và lọc dữ liệu
Trả lời
5
Đọc
103
Emyeuexcel
Emyeuexcel
L
Hỏi lỗi excel bị tràn trang khi in
Trả lời
3
Đọc
78
Hoàng Tuấn 868
H
E
  • Question Question
VBA tự động thay đổi tham chiếu vùng (range và cell) khi insert dòng cột trong sheet tính toán
    • Cười
Trả lời
5
Đọc
129
eagle12
E
D
Tổng hợp dữ liệu từ các sheet sang sheet tổng
Trả lời
3
Đọc
154
dohungmo
D
T
font chu trong excel (1 người xem)
Trả lời
2
Đọc
77
Hoàng Tuấn 868
H
khuong182018
  • Question Question
Nhờ anh chị sửa lỗi setfocus ở textbox
Trả lời
9
Đọc
170
khuong182018
khuong182018
N
File chia băng tự động từ cuộn mẹ theo khổ băng và khối lượng băng cho trước
Trả lời
0
Đọc
46
nguyenanhtruong2409
N
SA_DQ
Copilot bình luận về một ván cờ vua
Trả lời
0
Đọc
78
SA_DQ
SA_DQ
T
Xin giúp đỡ lọc dữ liệu
    • Cười
Trả lời
4
Đọc
119
pycckuu410
pycckuu410
Nguyễn Duy Tuân
[New] BSAC v3.0 bộ công cụ lập trình phần mềm chuyên nghiệp trong VBA
    • Thích
Trả lời
13
Đọc
4K
Nguyễn Duy Tuân
Nguyễn Duy Tuân
H
  • Question Question
Code Sổ Chi Tiết Tài Khoản
Trả lời
8
Đọc
335
hieuvietmy2020
H
befaint
Chia sẻ tâm tư, xả nỗi lòng (3 người xem)
    • Thích
6 7 8
Trả lời
778
Đọc
75K
SA_DQ
SA_DQ
H
Chia sẻ file in Phiếu điều tra PCGD
    • Thích
    • Yêu thích
    • Cảm ơn
Trả lời
12
Đọc
448
HUONGHCKT
H
V
Hỏi công thức để làm khối lượng trong xây dựng. Xin cảm ơn
Trả lời
11
Đọc
526
phanphu_91
P
Linhnv0001
Hỏi - Cách kiểm tra laptop là hàng lắp ráp hay không
Trả lời
3
Đọc
276
Lê Duy Thương
Lê Duy Thương
K
Nhờ anh chị làm công thức lọc dữ kiện ngày từ bảng 1 sang rút gọn ngày ở bảng 2.
Trả lời
2
Đọc
192
Lê Duy Thương
Lê Duy Thương
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

Thời gian đếm ngược.

000
Ngày
00
Giờ
00
phút
00
giây
Thân mời tham dự sự kiện sinh nhật GPE 2025
Back
Top Bottom