Excel'de digital saat oluşturma

[zitronelila]

Merhaba, excelde dosyayı açtığımda otomatik olarak aktif olacak şekilde digital saat oluşturmak istiyorum fakat uygun kodu bir türlü bulamadım. Konu ile ilgili yardımcı olursanız sevinirim. Şimdiden teşekkürler.

 

[cems]

Yapay zeka cevabıdır , excel sayfası a1 hücresine gore duzenlemedir.

1. Excel dosyanızı açın.
2. ALT + F11 tuşlarına basarak VBA penceresini açın.
3. Insert menüsünden Module seçeneğini seçin. Yeni bir modül açılacak.

Aşağıdaki kodu açılan modül penceresine yapıştırın:


Dim nextTick As Double

Sub StartClock()
nextTick = Now + TimeValue("00:00:01") ' 1 saniye bekle
Application.OnTime nextTick, "UpdateClock"
End Sub

Sub UpdateClock()
ThisWorkbook.Sheets(1).Range("A1").Value = Format(Now, "hh:mm:ss") ' A1 hücresine saat yaz
StartClock ' Zamanlayıcıyı yeniden başlat
End Sub

Sub StopClock()
On Error Resume Next
Application.OnTime nextTick, "UpdateClock", , False
End Sub

1. Sol taraftaki "ThisWorkbook" nesnesine çift tıklayın.
2. Aşağıdaki kodu yapıştırın:

Private Sub Workbook_Open()
StartClock
End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)
StopClock
End Sub

1. Dosyanızı Excel Macro-Enabled Workbook (*.xlsm) formatında kaydedin.

Excel dosyanızı her açtığınızda, A1 hücresinde otomatik olarak güncellenen bir dijital saat göreceksiniz. Dosyayı kapattığınızda saat güncellemeyi durduracaktır.

 

[Biolightant]

Merhaba,

@Merhum İdris SERDAR güzel bir çalışması

https://www.excelgurusu.com/analog-saat-tarih/

 

[adventurous26]

peki sadece sayfa 1 demi yazıyor ben tüm sayfalarda a1 hücresinde çalışmasını istiyorum ama yapamadım

 

[pitchoute]

Merhabalar, öncelikle şu modülü ekleyin;

Dim NextTick As Date

Sub ShowTime()
    Dim ws As Worksheet
    For Each ws In ThisWorkbook.Worksheets
        ws.Range("A1").Value = Format(Now, "HH:mm:ss")
    Next ws
    NextTick = Now + TimeValue("00:00:01")
    Application.OnTime NextTick, "ShowTime"
End Sub

Sub StopTime()
    On Error Resume Next
    Application.OnTime EarliestTime:=NextTick, Procedure:="ShowTime", Schedule:=False
End Sub

Sonrasında Proje Gezgininde (sol taraftaki panoda), ThisWorkbook nesnesine çift tıklayın. Açılan kod penceresine aşağıdaki kodları ekleyin:

Private Sub Workbook_Open()
    ShowTime
End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)
    StopTime
End Sub

Son olarak Dosya > Seçenekler > Güven Merkezi > Güven Merkezi Ayarları > Makro Ayarları yolunu izleyin ve Tüm makroları etkinleştir seçeneğini seçin.

Yedek alıp deneyin lütfen, denedikten sonra sonucu paylaşabilir misiniz?

 

[adventurous26]

teşekkür ederim gayet güzel çalışıyor

 

[pitchoute]

Çalışmasıyla kaynak olan @Merhum İdris SERDAR'a dualarımızla...

Rica ederim, iyi çalışmalar

 

[zitronelila]

Merhaba, öncelikle teşekkür ederim gayet çalışıyor. Yalnız şöyle bir sıkıntı yaşıyorum bunu uyguladığım excel dosyasını açtığımda fare imleci dönüp duruyor. Mesela hücre kenarları çizmek istediğim bu durumdan dolayı kalemi seçtiğimde çizemiyorum. Bununla ilgili yardımcı olabilir misiniz?

 

[cems]

Saniye işlevini kaldırın zira saat her saniye çalışınca diğer işlevler bloke olur

 

[zitronelila]

Nasıl yapacağım onu peki tam bilmiyorum da

 

[cems]

Hangi kodu kullandınız ? O kodu aldıgınız uye yardımcı olacaktır .

 

[pitchoute]

Merhaba, öncelikle teşekkür ederim gayet çalışıyor. Yalnız şöyle bir sıkıntı yaşıyorum bunu uyguladığım excel dosyasını açtığımda fare imleci dönüp duruyor. Mesela hücre kenarları çizmek istediğim bu durumdan dolayı kalemi seçtiğimde çizemiyorum. Bununla ilgili yardımcı olabilir misiniz?

Bunun çözümü için ya her saniye güncellenmesini geciktireceğiz ya da aynı excel sayfasında işlem yaparken devre dışı bırakacağız. İkisini de bırakıyorum, deneyip karar verirsiniz.

Güncelleme Sıklığını Azaltma;

Dim NextTick As Date

Sub ShowTime()
    Dim ws As Worksheet
    For Each ws In ThisWorkbook.Worksheets
        ws.Range("A1").Value = Format(Now, "HH:mm:ss")
    Next ws
    NextTick = Now + TimeValue("00:01:00")
    Application.OnTime NextTick, "ShowTime"
End Sub

Sub StopTime()
    On Error Resume Next
    Application.OnTime EarliestTime:=NextTick, Procedure:="ShowTime", Schedule:=False
End Sub

İşlem yapılırken tetiklenmeyi kaldırma;

Sub ShowTime()
    Application.EnableEvents = False
    Application.ScreenUpdating = False
    Dim ws As Worksheet
    For Each ws In ThisWorkbook.Worksheets
        ws.Range("A1").Value = Format(Now, "HH:mm:ss")
    Next ws
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    NextTick = Now + TimeValue("00:00:10")
    Application.OnTime NextTick, "ShowTime"
End Sub

 

[Tevfik_Kursun]

Merhaba Arkadaşım,
Saniye kaldırılmış hali
Silinebilir bağlantı Ornek_Dosya_2
İyi çalışmalar