Yanıp sönen hücre yapma

[fehdur]

On Error GoTo hata
deg = InputBox("aranacak degeri giriniz.")
Range("a1:a1000").Find(deg).Select
Exit Sub
hata:
MsgBox "aranilan deger bulunamadi"

Inputbox'a girilen değer bulunduğunda ilgili hücre belli bir süre yanıp sönecek.
Makro bu kodun altına yazılacak.Şimdiden Teşekkürler.

 

[BAZGİRET]

Bunu inceleyin;

Sub bul()
On Error GoTo hata
deg = InputBox("aranacak degeri giriniz.")
Range("a1:a1000").Find(deg).Select
If deg = ActiveCell.Value Then
For k = 1 To 10
ActiveCell.Interior.ColorIndex = 5
ActiveCell.Font.ColorIndex = 6
ActiveCell.Font.Bold = True

                  basla = Timer
                  bekle = 1
                  While Timer < basla + bekle
                  DoEvents
                  Wend
ActiveCell.Interior.ColorIndex = 6
ActiveCell.Font.ColorIndex = 5
ActiveCell.Font.Bold = True

                     basla = Timer
                  bekle = 1
                  While Timer < basla + bekle
                  DoEvents
                  Wend
Next k
End If
ActiveCell.Interior.ColorIndex = xlNone
ActiveCell.Font.ColorIndex = 0
ActiveCell.Font.Bold = False

Exit Sub
hata:
MsgBox "aranilan deger bulunamadi"
End Sub

 

[muratgunay48]

Bunu inceleyin;

Sub bul()
On Error GoTo hata
deg = InputBox("aranacak degeri giriniz.")
Range("a1:a1000").Find(deg).Select
If deg = ActiveCell.Value Then
For k = 1 To 10
ActiveCell.Interior.ColorIndex = 5
ActiveCell.Font.ColorIndex = 6
ActiveCell.Font.Bold = True

                  basla = Timer
                  bekle = 1
                  While Timer < basla + bekle
                  DoEvents
                  Wend
ActiveCell.Interior.ColorIndex = 6
ActiveCell.Font.ColorIndex = 5
ActiveCell.Font.Bold = True

                     basla = Timer
                  bekle = 1
                  While Timer < basla + bekle
                  DoEvents
                  Wend
Next k
End If
ActiveCell.Interior.ColorIndex = xlNone
ActiveCell.Font.ColorIndex = 0
ActiveCell.Font.Bold = False

Exit Sub
hata:
MsgBox "aranilan deger bulunamadi"
End Sub

Hocam çok güzel bir çalışma. Ancak hangi hücreye tıklanırsa yanıp sönmeye başlıyor. Ve aranan değer boş tıklandığında son hücre yanıp sönmeye başlıyor. Nasıl düzeltebiliriz.
Saygılarımla.

 

[BAZGİRET]

Hariçten tıklamayla flash makrosunun devreye girmemesi gerekir. Ancak inputboxa girilen veri ile tetiklenir. Yukardaki isteğe göre düzenlendi.

 

[muratgunay48]

Hariçten tıklamayla flash makrosunun devreye girmemesi gerekir. Ancak inputboxa girilen veri ile tetiklenir. Yukardaki isteğe göre düzenlendi.

Emeğinize sağlık hocam.

 

[muratgunay48]

Bunu inceleyin;

Sub bul()
On Error GoTo hata
deg = InputBox("aranacak degeri giriniz.")
Range("a1:a1000").Find(deg).Select
If deg = ActiveCell.Value Then
For k = 1 To 10
ActiveCell.Interior.ColorIndex = 5
ActiveCell.Font.ColorIndex = 6
ActiveCell.Font.Bold = True

                  basla = Timer
                  bekle = 1
                  While Timer < basla + bekle
                  DoEvents
                  Wend
ActiveCell.Interior.ColorIndex = 6
ActiveCell.Font.ColorIndex = 5
ActiveCell.Font.Bold = True

                     basla = Timer
                  bekle = 1
                  While Timer < basla + bekle
                  DoEvents
                  Wend
Next k
End If
ActiveCell.Interior.ColorIndex = xlNone
ActiveCell.Font.ColorIndex = 0
ActiveCell.Font.Bold = False

Exit Sub
hata:
MsgBox "aranilan deger bulunamadi"
End Sub

Hocam, dosyayı indirdim. Eğer ben yanlış yapmıyorsam iki hata var sanırım. Öncelikle, aranan değer bulunduktan sonra tıkladığınız her hücre renkleniyor. İkinci olarak, örneğin 111 yazdım, aranan değer bulunamadı diyor.
Saygılarımla.

 

[Korhan Ayhan]

Alternatif;

Option Explicit

#If VBA7 And Win64 Then
    Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#Else
    Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#End If

Sub Ara()
    Dim Bul As Range, Veri As Variant, Say As Integer
    On Error GoTo Hata
    Veri = Application.InputBox("Aranacak değeri giriniz.")
    If Veri = False Then Exit Sub
    If Veri = "" Then
        MsgBox "Lütfen aramak istediğiniz değeri giriniz.!", vbExclamation
        Exit Sub
    End If
    
    Set Bul = Range("A1:A1000").Find(Veri)
    If Bul Is Nothing Then GoTo Hata
    
    Bul.Select
    
    Do While Say <= 20
        DoEvents
        If Bul.Interior.ColorIndex = 3 Then
            Bul.Interior.ColorIndex = xlNone
        Else
            Bul.Interior.ColorIndex = 3
        End If
        Say = Say + 1
        Sleep 500
    Loop
    
    Bul.Interior.ColorIndex = xlNone
    
    Exit Sub
Hata: MsgBox "Aranılan değer bulunamadı!", vbCritical
End Sub

 

[BAZGİRET]

Evet. Bu durumda Korhan Bey'in önerdiği kod daha kullanışlı.

 

[ALKAAZER]

Merhaba Arkadaşlar,

Eklediğim dosyada gecikme günü hesaplaması mevcut .24 saati geçen her gecikme kırmızı renkte yanıp sönebilirmi, (G sütunu içinde yer alan süreler) excel her açıldığında otomatik başlasın. yardımcı olursanız sevinirim teşekkürler.