Makro İle Belirli Bir Tarihten önceki satırları kilitlemek

[respecteams]

Merhaba Arkadaşlar,

Elimde Mikro Database'dan çekilmiş Personel Listesi var. Personellerin Geldi gelmedi izinli girdi çıktılarını yapıyorum.
İstediğim, personelin sigorta başlangıç tarihinden önceki tarih hücrelerinin o personel için kilitlenmesi/işlem yapılmaması.
Makro ile böyle bir kilitleme yapmam mümkün müdür? Mümkünse nasıl yapabilirim? Yardımcı olursanız çok sevinirim.

 

[respecteams]

Bu arada excel kullanıyorum mikrodan sadece veri çektim yanlış anlaşılmasın

 

[Ömer]

Merhaba,

Sorunuzun daha anlaşılır olması için örnek bir Excel dosyası hazırlayıp dosya içerisinde gerekli detaylı açıklamaları yapar mısınız.

Dosya Yükle - Dosya Upload

Dosyalarınızı ücretsiz yükleyebilir ve paylaşabilirsiniz.

dosya.co

.

 

[respecteams]

Yükledim.

İndir Kitap2

Dosyayı indir Kitap2

dosya.co

Tabloda sigorta girişleri mevcut

 

[Ömer]

Eklediğini dosyadaki personel listesi benzersiz bir liste. Bu listede ne olması gerekiyor. Detaylı açıklama yapmanızı rica etmiştim.

 

[respecteams]

Bu liste personel devamsızlık listesi olacak. Personel isimlerinin yanında sigorta giriş tarihleri var ve tablonun geri kalanı üst tarafta 1 ay olacak şekilde tarihler yazıyor. Bana gereken her personel için, sigorta giriş tarihinden önceki günler tabloda kilitlenmeli.

 

[respecteams]

Dosyayı düzenledim. Tarihler daha net.

İndir Kitap2

Dosyayı indir Kitap2

dosya.co

 

[Ömer]

Bu şekilde konuyu biliyormuşum gibi değil, örnek vererek detaylı açıklamanız gerekir.

Örneğin;
DAMLA AĞZIAÇIK ve DOĞUKAN ARMİŞEN için hangi hücrelerin(adreslerini de vererek) kilitlenmesi gerekiyor ve neden?

 

[respecteams]

Bu şekilde konuyu biliyormuşum gibi değil, örnek vererek detaylı açıklamanız gerekir.

Örneğin;
DAMLA AĞZIAÇIK ve DOĞUKAN ARMİŞEN için hangi hücrelerin(adreslerini de vererek) kilitlenmesi gerekiyor ve neden?

Ben mikro database den excele personel isim listesi ve sigorta giriş tarihlerini aktardım. Otomatik olarak kendisini güncelliyor yeni personeller eklendikçe. Benim yapamadığım konu şu;
Personel listesi tablo şeklinde ve amacı devamsızlık listesi oluşturmak. Personellerin sigorta giriş tarihlerinden önceki günlerin o personel için kilitlenmesi/işlem yapılmaması gerekiyor. Bunu elle yapmak mümkün ama mikrodan tablo otomatik güncellendiğinden dolayı, makro kodlarıyla otomatik olarak yeni eklenen personelin sigorta tarihinden önceki günlerin kilitlenmesini hedefliyorum.

 

[Ömer]

Sayfa koruma şifresini "+" olarak belirledim, siz kendinize göre değiştirirsiniz.

Sub kilitle()
   
    Dim i As Long, t1 As Date, s1 As Date, s2 As Date, son As Long, g1 As Byte
   
    s1 = DateSerial([A1], [B1], 1)
    s2 = WorksheetFunction.EoMonth(s1, 0)
    son = Cells(Rows.Count, "C").End(xlUp).Row
   
    Application.ScreenUpdating = False
    ActiveSheet.Unprotect "+"
   
    'With Range(Cells(4, "D"), Cells(Rows.Count, "AH"))
    With Cells
        .Locked = False
        .FormulaHidden = False
    End With

    For i = 4 To son
        t1 = DateSerial(Year(Cells(i, "C")), Month(Cells(i, "C")), 1)
        If t1 < s1 Then
            With Cells(i, "D").Resize(1, 31)
                .Locked = True
                .FormulaHidden = True
            End With
        End If
        If t1 >= s1 And t1 <= s2 Then
            g1 = Day(Cells(i, "C"))
            If g1 <> 1 Then
                With Range(Cells(i, "D"), Cells(i, g1 + 3))
                    .Locked = True
                    .FormulaHidden = True
                End With
            End If
        End If
    Next i
   
    ActiveSheet.Protect "+"
    Application.ScreenUpdating = True
   
End Sub

 

[respecteams]

Sayfa koruma şifresini "+" olarak belirledim, siz kendinize göre değiştirirsiniz.

Sub kilitle()
  
    Dim i As Long, t1 As Date, s1 As Date, s2 As Date, son As Long, g1 As Byte
  
    s1 = DateSerial([A1], [B1], 1)
    s2 = WorksheetFunction.EoMonth(s1, 0)
    son = Cells(Rows.Count, "C").End(xlUp).Row
  
    Application.ScreenUpdating = False
    ActiveSheet.Unprotect "+"
  
    'With Range(Cells(4, "D"), Cells(Rows.Count, "AH"))
    With Cells
        .Locked = False
        .FormulaHidden = False
    End With

    For i = 4 To son
        t1 = DateSerial(Year(Cells(i, "C")), Month(Cells(i, "C")), 1)
        If t1 < s1 Then
            With Cells(i, "D").Resize(1, 31)
                .Locked = True
                .FormulaHidden = True
            End With
        End If
        If t1 >= s1 And t1 <= s2 Then
            g1 = Day(Cells(i, "C"))
            If g1 <> 1 Then
                With Range(Cells(i, "D"), Cells(i, g1 + 3))
                    .Locked = True
                    .FormulaHidden = True
                End With
            End If
        End If
    Next i
  
    ActiveSheet.Protect "+"
    Application.ScreenUpdating = True
  
End Sub

teşekkürler, kod hata vermiyor ama sigorta tarihlerinden önceki günlerle oynayabiliyorum?. Makroyu yapıştırdıktan sonra başka bir işlem yapmam gerekiyor mu ve ikinci attığım dosya için mi oluşturdunuz?

 

[Ömer]

Kodları module ekledikten sonra çalıştırdınız mı?

Eki inceleyiniz. Kilitle butonuna bastıktan sonra deneyiniz.
Eğer aynı giriş gününe de hücre girişine izin verecekse kodlardaki; Cells(i, g1 + 3) bu bölümdeki +3 ü +2 olarak değiştirirsiniz.

İndir Kitap2 Kopya

Dosyayı indir Kitap2 Kopya

dosya.co

.

 

[respecteams]

Kodları module ekledikten sonra çalıştırdınız mı?

Eki inceleyiniz. Kilitle butonuna bastıktan sonra deneyiniz.
Eğer aynı giriş gününe de hücre girişine izin verecekse kodlardaki; Cells(i, g1 + 3) bu bölümdeki +3 ü +2 olarak değiştirirsiniz.

İndir Kitap2 Kopya

Dosyayı indir Kitap2 Kopya

dosya.co

.

Teşekkürler fakat şuanda da hiçbir sutüna izin vermiyor. Giriş tarihlerinden sonraki günler değiştirilebilir olmalı ya da öyle ayarladıysanız nerede hata yapıyorum çözemedim. Kilitle tuşuna bastıktan sonra da aynı şekil

 

[respecteams]

Kodları module ekledikten sonra çalıştırdınız mı?

Eki inceleyiniz. Kilitle butonuna bastıktan sonra deneyiniz.
Eğer aynı giriş gününe de hücre girişine izin verecekse kodlardaki; Cells(i, g1 + 3) bu bölümdeki +3 ü +2 olarak değiştirirsiniz.

İndir Kitap2 Kopya

Dosyayı indir Kitap2 Kopya

dosya.co

.

misal tekin çakırda olması gerektiği gibi ama doğukan da kilitli diyor.. acaba bir yerde çakışıyor mudur

 

[Ömer]

Doğukan 01.04.2021 de girmiş. Sizin A1 ve B1 deki verilere göre ölçütünüz Ekim.2021 bu durumda Ekim tablosunda Doğukan için veri girişine izin vermiyor.
Kurgu hatalı mı?

 

[Ömer]

Birde aşağıdaki gibi deneyiniz. Sanırım istediğiniz bu. Eski kodları silip aşağıdakileri aynı bölüme yapıştırıp buton ile çalıştırın.

Sub kilitle()
  
    Dim i As Long, t1 As Date, s1 As Date, s2 As Date, son As Long, g1 As Byte
  
    s1 = DateSerial([A1], [B1], 1)
    s2 = WorksheetFunction.EoMonth(s1, 0)
    son = Cells(Rows.Count, "C").End(xlUp).Row
  
    Application.ScreenUpdating = False
    ActiveSheet.Unprotect "+"
  
    'With Range(Cells(4, "D"), Cells(Rows.Count, "AH"))
    With Cells
        .Locked = False
        .FormulaHidden = False
    End With

    For i = 4 To son
        t1 = DateSerial(Year(Cells(i, "C")), Month(Cells(i, "C")), 1)
        'If t1 < s1 Then
        '   With Cells(i, "D").Resize(1, 31)
        '      .Locked = True
        '        .FormulaHidden = True
        '    End With
        'End If
        If t1 >= s1 And t1 <= s2 Then
            g1 = Day(Cells(i, "C"))
            If g1 <> 1 Then
                With Range(Cells(i, "D"), Cells(i, g1 + 2))
                    .Locked = True
                    .FormulaHidden = True
                End With
            End If
        End If
    Next i
  
    ActiveSheet.Protect "+"
    Application.ScreenUpdating = True
  
End Sub

 

[respecteams]

Kurguyu kontrol ettim, fixlenecek bug yok. Düzenlediğiniz kodu deneyip tekrar yazacağım, ilgi ve alakanız için tekrar teşekkür ediyorum şuanda hayatımı kurtarıyorsunuz

 

[respecteams]

Birde aşağıdaki gibi deneyiniz. Sanırım istediğiniz bu. Eski kodları silip aşağıdakileri aynı bölüme yapıştırıp buton ile çalıştırın.

Sub kilitle()
  
    Dim i As Long, t1 As Date, s1 As Date, s2 As Date, son As Long, g1 As Byte
  
    s1 = DateSerial([A1], [B1], 1)
    s2 = WorksheetFunction.EoMonth(s1, 0)
    son = Cells(Rows.Count, "C").End(xlUp).Row
  
    Application.ScreenUpdating = False
    ActiveSheet.Unprotect "+"
  
    'With Range(Cells(4, "D"), Cells(Rows.Count, "AH"))
    With Cells
        .Locked = False
        .FormulaHidden = False
    End With

    For i = 4 To son
        t1 = DateSerial(Year(Cells(i, "C")), Month(Cells(i, "C")), 1)
        'If t1 < s1 Then
        '   With Cells(i, "D").Resize(1, 31)
        '      .Locked = True
        '        .FormulaHidden = True
        '    End With
        'End If
        If t1 >= s1 And t1 <= s2 Then
            g1 = Day(Cells(i, "C"))
            If g1 <> 1 Then
                With Range(Cells(i, "D"), Cells(i, g1 + 2))
                    .Locked = True
                    .FormulaHidden = True
                End With
            End If
        End If
    Next i
  
    ActiveSheet.Protect "+"
    Application.ScreenUpdating = True
  
End Sub

yeni kodlarınızla denedim, aynı hata devam ediyor. misal ŞABAN GÖKTEPE de olması gerektiği gibi ama pek çoğunda değil.

 

[Ömer]

Doğru sonuçlanmayan 3-4 isim yazar mısınız.

 

[respecteams]

Doğru sonuçlanmayan 3-4 isim yazar mısınız.

Melek Baysal, ABDULHADI DEILEH, RAMAZAN KURT, ALİ KARA ve daha pek çok isim, sadece ŞABAN GÖKTEPE olması gerektiği gibi sanırım