Takvime Kayıt Yapmak

[speech_free]

Merhaba,

İki sayfadan oluşan bir Excel çalışma kitabımız var. Birincisi Etkinlikler, diğeri de Takvim. İhtiyacımıza göre kendi oluşturduğum takvimdir. Bu şekilde yapmamın sebebi çıktı alırken 3 haftalık dönemlere ihtiyaç duyuyor olmamız. Örnek dosya ekledim. Gerekli açıklamalar da içinde bulunuyor. Bu konuda yardımcı olabilecek var mı?

http://s5.dosya.tc/server4/i7v0n2/takvim.rar.html

Çok teşekkür ederim.

 

[Ömer]

Merhaba,

Silme işlemi yapmaz.

Benim anladığım ve uyguladığım: Etkinlik sayfasında A sütunundaki tüm değerleri takvim sayfasında arar, bulursa ilgili satırlarına B sütunundaki değeri yazar. Eğer takvimdeki tarihin olduğu sütun doluysa, yani tablo yapısına göre belirlediğiniz 7 satırda doluysa yazma işlemi yapmaz.

Sub Takvime_ekle()

    Dim St As Worksheet, i As Long, c As Range, Adr As String, son As Long, a
    
    Set St = Sheets("Takvim")
    
    Application.ScreenUpdating = False
    Sheets("Etkinlikler").Select
    
[COLOR="Blue"]    a = St.Range("B3")
    St.Range("B3:G479").SpecialCells(xlCellTypeConstants, 23).ClearContents
    St.Range("B3") = a[/COLOR]
    
    For i = 2 To Cells(Rows.Count, "A").End(xlUp).Row
        Set c = St.Cells.Find(Cells(i, "A"), , xlValues, xlWhole)
        If Not c Is Nothing Then
            Adr = c.Address
            Do
                son = St.Cells(c.Row + 7, c.Column).End(xlUp).Row + 1
                If St.Cells(c.Row + 7, c.Column) <> "" Then Exit Do
                St.Cells(son, c.Column) = Cells(i, "B")
                Set c = St.Cells.FindNext(c)
            Loop While Not c Is Nothing And c.Address <> Adr
        End If
    Next i
        
End Sub

.

 

[speech_free]

Çok çok teşekkür ederim. Bir de sildirmeyi başarabilirsem tamamdır. Çünkü bu şekilde tekrarlanan veriler oluyor takvimde. Aslında silme makrosu da ekleyebilirim bunun öncesine ama sadece bu satırları silecek ve tarihlere dokunmayacak. Onu nasıl yaparım çok bilmiyorum. Tek bir hafta için yapabilirim de. Sayfa aşağı doğru akıp gidiyor ve arada tarih satırları da var.

Bu hali ile çok güzel bir başlangıç oldu. Elinize sağlık.

 

[Ömer]

#2 numaralı mesajdaki kodları düzenledim.

.

 

[speech_free]

Ömer Bey, teşekkürler. Tam istediğim gibi çalışıyor.

 

[speech_free]

Rahatsız ediyorum sizi Ömer Bey ama bir sorum olacaktı. Eğer ki satır silersem o hafta için o zaman kodun içerisinde sildiğim satır sayısı kadar eksiltme mi yapacağım? Size gönderdiğim dosyada 8 satır vardı ve bir satırı Notlar için ayrılmıştı. Bu durumda siz 7 yapmıştınız. Ben de satır sayısını 6 ya indirdim ve Notlar da yok artık. Bu durumda ben de kodun içindeki 7'yi 6 yapacağım sanırım. Doğru mudur?

son = St.Cells(c.Row + 7, c.Column).End(xlUp).Row + 1
                If son > c.Row + 7 Then Exit Do

 

[Ömer]

Sorunuza istinaden; evet 6 yazmanız gerekir.

Ek bilgi:

If son > c.Row + 6 Then Exit Do

yerine

If St.Cells(c.Row + 6, c.Column) <> "" Then Exit Do

Yazmak daha doğru olacaktır. Detaylı deneme yapmadığım için yeni fark ettim.

.

 

[speech_free]

Merhaba Ömer Bey,

Bu son verdiğiniz kod ile 7 tane kayıt bile olsa etkinlikler sayfasında, sadece 6 tanesini yazıyor. Eski hali ile 7. olanı gidip 6 satırlık yerdeki ilk satıra yazıyordu, bu da problem oluşturuyordu. Bu şekli ile süper oldu. Elinize sağlık.

 

[speech_free]

Ömer Bey günaydın,

Sayenizde kod ile istediğimi yapmıştık. Etkinlikler sayfasından Takvim sayfasına gönderiyordu ilgili tarihteki satırları hatırlarsanız. Ben bunu biraz kendime göre geliştirdim. Korhan Bey ve siz gene başka bir kod yardımında bulunmuştunuz M2'leri koyu yapmak için.

Şimdi ben Ocak, Şubat, Mart, Nisan şeklinde ayları da ayrı ayrı sayfa olarak ekledim ve sizin takvime gönder kodunu her sayfa için yeniledim. Takvim kodunun altında da bunları teker teker çağırdım ve böylece o sayfalarda verilerle doldu. Çok efektif bir yöntem değil tabi ama işimi görüyor. Belki hızlandırmak için birşey yapılabilir mi?

Sadece Ocak ayını gösteren kod ile birlikte paylaşıyorum. Diğer aylar için de aynı işlem yapılmıştır. Ay sayfalarında B sütunundan değil de C sütunundan başlanmıştır.

Sub Takvim()

    Dim St As Worksheet, i As Long, c As Range, Adr As String, son As Long, a
    
    Set St = Sheets("Takvim")
    
    Application.ScreenUpdating = False
    Sheets("Etkinlikler").Select
    
    a = St.Range("B7")
    St.Range("B7:G1500").SpecialCells(xlCellTypeConstants, 23).ClearContents
    St.Range("B7") = a
    
    For i = 2 To Cells(Rows.Count, "A").End(xlUp).Row
        Set c = St.Cells.Find(Cells(i, "A"), , xlValues, xlWhole)
        If Not c Is Nothing Then
            Adr = c.Address
            Do
                son = St.Cells(c.Row + 6, c.Column).End(xlUp).Row + 1
                If St.Cells(c.Row + 6, c.Column) <> "" Then Exit Do
                St.Cells(son, c.Column) = Cells(i, "B")
                Set c = St.Cells.FindNext(c)
            Loop While Not c Is Nothing And c.Address <> Adr
        End If
    Next i
Call Takvim_Ocak
Call Takvim_Subat
Call Takvim_Mart
Call Takvim_Nisan
Call Takvim_Mayis
Call Takvim_Haziran
Call Takvim_Temmuz
Call Takvim_Agustos
Call Takvim_Eylul
Call Takvim_Ekim
Call Takvim_Kasim
Call Takvim_Aralik
End Sub
Sub Takvim_Ocak()

    Dim St As Worksheet, i As Long, c As Range, Adr As String, son As Long, a
    
    Set St = Sheets("Ocak")
    
    Application.ScreenUpdating = False
    Sheets("Etkinlikler").Select
    
    a = St.Range("C2")
    St.Range("C2:H50").SpecialCells(xlCellTypeConstants, 23).ClearContents
    St.Range("C2") = a
    
    For i = 2 To Cells(Rows.Count, "A").End(xlUp).Row
        Set c = St.Cells.Find(Cells(i, "A"), , xlValues, xlWhole)
        If Not c Is Nothing Then
            Adr = c.Address
            Do
                son = St.Cells(c.Row + 6, c.Column).End(xlUp).Row + 1
                If St.Cells(c.Row + 6, c.Column) <> "" Then Exit Do
                St.Cells(son, c.Column) = Cells(i, "B")
                Set c = St.Cells.FindNext(c)
            Loop While Not c Is Nothing And c.Address <> Adr
        End If
    Next i
        
End Sub

Yukarıdaki kod sorunsuz bir şekilde çalışmaktadır fakat Korhan Bey'den aldığım kodu (aşağıdaki) her ay sayfasında buton ile çalıştırmaktayım. Yani teker teker sayfalara gidip butona basmam gerekiyor. Bu kodu da Takvim ya da Takvim_Ocak koduna entegre edip bu şekilde sadece Etkinlikler sayfasındaki butona basarak işimi halledebilir miyim? Kodu Takvim kodunun içinden çağırmayı denedim fakat çalışmadı.

Sub Duzenle()
    Dim Veri As Range, Bul As Integer, x As Integer, Karakter As String, Koyu As Range, Koyu2 As Range, Koyu3 As Range, Koyu4 As Range, Koyu5 As Range, Koyu6 As Range, bb As Range
    
    For Each Veri In Range("C2:H43")
        If Veri.Value <> "" Then
            Veri.Font.Bold = False
            Bul = InStr(1, Veri.Value, " M2")
            If Bul > 0 Then
                For x = Bul To 1 Step -1
                    Karakter = Mid(Veri.Value, x, 1)
                    Select Case Karakter
                        Case " ", 0 To 9, ".", ","
                        Case Else
                            Exit For
                    End Select
                Next
                Veri.Characters(x + 1, Bul - x + 2).Font.Bold = True
            End If
        End If
    Next
    For Each Koyu In Range("C2:H2")
    Koyu.Font.Bold = True
    Next
    For Each Koyu2 In Range("C9:H9")
    Koyu2.Font.Bold = True
    Next
    For Each Koyu3 In Range("C16:H16")
    Koyu3.Font.Bold = True
    Next
    For Each Koyu4 In Range("C23:H23")
    Koyu4.Font.Bold = True
    Next
    For Each Koyu5 In Range("C30:H30")
    Koyu5.Font.Bold = True
    Next
    For Each Koyu6 In Range("C37:H37")
    Koyu6.Font.Bold = True
    Next
    [COLOR="Red"]For Each bb In Range("C2:H43")
      ' Aralıktaki metni büyük harflere dönüştür.
      bb.Value = UCase(bb.Value)
   Next[/COLOR]
End Sub

Bu arada yukarıdaki kodun içinde kırmızı ile işaretlediğim bölümü ekledikten sonra o aralıktaki tarih yazan formülleri siliyor ve kafasına göre bir tarih koyuyor. Bunun sebebi ne olabilir? Büyük harfe çevirirken de ı harfi I olmuyor.

Yardımlarınız için teşekkür ederim.