Bugünün tarihi geldiğinde animasyonu başlatsın

[ismail-34]

Değerli Excel web ailesine selamlar

Benim sorum a sütünundaki çek ödeme tarihlerinde bugünün tarihi eğer varsa sayfadaki gif animasonunu oynatsın yoksa animasyonu durdursun.

böyle bir şey mümkünmü

örnek ektedir.

herkese saygılar sevgiler.

 

[murat_fidan]

dosyanızı link atarak paylaşırmısınız indiremiyorum

 

[Tevfik_Kursun]

Yardımcı olayım
Tarihe_Gore_Animasyon
iyi çalışmalar

 

[mesuttasar]

Animasyon değilde hücrede çalışan kodlar ektedir.

Sub deneme()
Dim x, i As Long
For x = 1 To 10000
    If Cells(x, 1) = "" Then GoTo 10
    If Cells(x, 1) <> Date Then
    Cells(x, 1).Select
        With Selection.Interior
        .Pattern = xlNone
        .TintAndShade = 0
        .PatternTintAndShade = 0
        End With
    End If

If Cells(x, 1) = Date Then
        Cells(x, 1).Select
    For i = 1 To 5
        With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .Color = 65535
        .TintAndShade = 0
        .PatternTintAndShade = 0
        Application.Wait (Now + TimeValue("00:00:01"))
        With Selection.Interior
        .Pattern = xlNone
        .TintAndShade = 0
        .PatternTintAndShade = 0
        End With
         Application.Wait (Now + TimeValue("00:00:01"))
        End With
        With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .Color = 65535
        .TintAndShade = 0
        .PatternTintAndShade = 0
        End With
    Next i
End If
Next x
10
End Sub

 

[ismail-34]

Animasyon değilde hücrede çalışan kodlar ektedir.

Sub deneme()
Dim x, i As Long
For x = 1 To 10000
    If Cells(x, 1) = "" Then GoTo 10
    If Cells(x, 1) <> Date Then
    Cells(x, 1).Select
        With Selection.Interior
        .Pattern = xlNone
        .TintAndShade = 0
        .PatternTintAndShade = 0
        End With
    End If

If Cells(x, 1) = Date Then
        Cells(x, 1).Select
    For i = 1 To 5
        With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .Color = 65535
        .TintAndShade = 0
        .PatternTintAndShade = 0
        Application.Wait (Now + TimeValue("00:00:01"))
        With Selection.Interior
        .Pattern = xlNone
        .TintAndShade = 0
        .PatternTintAndShade = 0
        End With
         Application.Wait (Now + TimeValue("00:00:01"))
        End With
        With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .Color = 65535
        .TintAndShade = 0
        .PatternTintAndShade = 0
        End With
    Next i
End If
Next x
10
End Sub

Teşekkürler. yalnız sayfa açıldığında otomatik çalışsın ve 5 tekrar sonrası kalan rengi sarı olmasın eski rengi kalsın istiyorum mümkünmü.

 

[mesuttasar]

"Sayfa açıldığında" derken ne demek istediğinizi tam anlayamadım, çalışma kitabını açtığınızda kodun çalışması için aşağıdaki kodları, Workbook_Open prosedürünün altına, kitabı açtıktan sonra tarihlerin olduğu sayfayı seçtiğiniz zaman çalışması içinde Worksheet_Acticate prosedürünün altına yapıştırabilirsiniz.

Çalışma kitabı açıldığında çalışan kodlar için	Private Sub Workbook_Open() 'aşağıdaki kodlar buraya gelecek End Sub
Kitap açıldıktan sonra tarihlerin olduğu sayfası seçince çalışan kodlar için	Private Sub Worksheet_Activate() 'aşağıdaki kodlar buraya gelecek End Sub

Dim x, i As Long
For x = 1 To 10000
    If Cells(x, 1) = "" Then GoTo 10
    If Cells(x, 1) <> Date Then
    Cells(x, 1).Select
        With Selection.Interior
        .Pattern = xlNone
        .TintAndShade = 0
        .PatternTintAndShade = 0
        End With
    End If

If Cells(x, 1) = Date Then
        Cells(x, 1).Select
    For i = 1 To 5
        With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .Color = 65535
        .TintAndShade = 0
        .PatternTintAndShade = 0
        Application.Wait (Now + TimeValue("00:00:01"))
        With Selection.Interior
        .Pattern = xlNone
        .TintAndShade = 0
        .PatternTintAndShade = 0
        End With
         Application.Wait (Now + TimeValue("00:00:01"))
        End With
     
    Next i
End If
Next x
10

 

[ismail-34]

Teşekkürler Mesut bey çok yararlı oldu.Sağolun varolun.