Takvim ekleme

[sdegirmenci]

Değerli Hocalarım merhaba;
Ekteki dosyam üzerinde Forumdan da yararlanarak bazı hücrelere takvim eklemeye çalıştım ama bir türlü başarılı olamadım Ekteki sayfa üzerinde açıklama yaptım Yardımcı olursanız çok sevinirim. Hoşçakalın

 

[hamitcan]

İlgili kodları aşağıdakiler ile değiştirin.

Private Sub Calendar1_Click()
ActiveCell = FormatDateTime(Calendar1.Value, vbShortDate)
Calendar1.Visible = False
End Sub


Private Sub Worksheet_SelectionChange(ByVal Target As Range)
 If Not Intersect(Target, [L14:R14,V14,V16,V24,BL18]) Is Nothing Then
    Calendar1.Visible = True
 Else
    Calendar1.Visible = False
End If
Calendar1.Top = ActiveCell.Top + 30
Calendar1.Left = ActiveCell.Left + 30
End Sub

 

[sdegirmenci]

Hocam ilginize teşekkür ederim.
Kodları dediğiniz gibi değiştirdim ama hata vermekte. Sayın Evren GİZLEN Hocamızın da aşağıdaki linkte ekli dosyasını evdeki bilgisayarda açtığımda hata vermekte . Oysa iş yerinde açmakta idi.Sanırım bir özellik eklememiz gerekiyor.
http://www.excel.web.tr/f53/foruma-tekrar-merhaba-t57884.html

 

[hamitcan]

Sorun ne tam olarak anlayamadım.

 

[sdegirmenci]

takvim ekleme

Hocam evdeki bilgisayarımda takvim eklentisini ekleyemedim. şu anda iş yerimdeyim takvim eklentisini ekledim.Ancak sıkıntım şurada;
Bazı hücreler seçildiğinde açılır kutular otomatik açılsın, bazı hücreler seçildiğinde takvim açılsın iki kodu yan yanda çalıştıramadım aşağıda; biri çalışınca diğeri çalışmıyor,

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Intersect(Target, Range("L16,L18,AN3,AN14,AN16,L20,L26,AN18")) Is Nothing Then Exit Sub 'Aktif olduğunda bu hücrelerdeki açılır kutulur açılması için
SendKeys "%{down}"

If Intersect(Target, [L14,V16,V18,V24,BL18]) Is Nothing Then 'Aktif olduğunda takvim açılsın


Calendar1.Visible = False
Exit Sub
Else
Calendar1.Value = Date
Calendar1.Visible = True
End If
Calendar1.Top = ActiveCell.Top + 20
Calendar1.Left = ActiveCell.Left + 0


End Sub

 

[hamitcan]

Kodu bu şekilde kullanın.

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Not Intersect(Target, [L14:R14,V14,V16,V24,BL18]) Is Nothing Then
       Calendar1.Visible = True
       Calendar1.Top = ActiveCell.Top + 30
       Calendar1.Left = ActiveCell.Left + 30
    Else
        Calendar1.Visible = False
    End If
    If Not Intersect(Target, [L16,L18,AN3,AN14,AN16,L20,L26,AN18]) Is Nothing Then
        SendKeys "%{down}"
    End If
End Sub

 

[sdegirmenci]

Hocam süpersiniz, Çok teşekkür ediyorum. Bütün işleriniz kolay gelsin.