Hiệu ứng nhấp nháy

Liên hệ QC
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

  • Book1.xlsm
    17.2 KB · Đọc: 30
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

  • FlickAlertXL.xlsm
    46.8 KB · Đọc: 9
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

  • ex.xlsx
    8.6 KB · Đọc: 7
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: 4
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

  • ex.xlsm
    17.2 KB · Đọc: 13
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

LuuAnh980
  • Question
Code lấy dữ liệu từ 3 file con.
2 3 4
Trả lời
71
Đọc
1K
VetMini
V
P
Nhờ các cao nhân cứu giúp em file excel bị lỗi phần mở rộng
Trả lời
1
Đọc
170
PHNGMINH
P
T
  • Question
Cho mình hỏi tại sao file mình chạy Sao lưu lại bị đầy bộ nhớ.
Trả lời
3
Đọc
98
BuiQuangThuan
B
phammaihuong90
Hàm tìm ngày gần nhất đạt được số lượng mục tiêu
Trả lời
4
Đọc
71
phammaihuong90
phammaihuong90
O
Kết hợp hàm value
Trả lời
1
Đọc
56
bebo021999
B
Xem thêm…

Facebook

Giaiphapexcel.com

Group

DIỄN ĐÀN GIẢI PHÁP EXCEL Group 1
DIỄN ĐÀN GIẢI PHÁP EXCEL Group 2

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

Back
Top Bottom