Çözüldü Servis ve fazla mesai takip tablosu

Bu şekilde bir deneyin.

okutkan' Alıntı:

Bu şekilde bir deneyin.

Kod:

Görüntülemek için giriş yapmanız gerekmektedir.
(62 satır)

Genişletmek için tıklayın ...

Merhaba Sayın @okutkan
Bu Son Düzenlemizle departman sayfalarındaki koruma sorunu çözüldü.
fakat tüm verilerin toplandığı Personel_Servis_Planı Sayfasında kilitli hüçrelerde bir kaç kez tıklamada ısrarcı olunduğunda sayfa koruması kalkıyor.
bu sorunun çözümünde desteğinize ihyacım var.

O sayfaya ait kodları paylaşır mısınız.

okutkan' Alıntı:

O sayfaya ait kodları paylaşır mısınız.

Genişletmek için tıklayın ...

Private Sub Worksheet_Activate()

ActiveSheet.Unprotect "1007"
Range("B6:L" & Rows.Count).ClearContents: Range("M6:AH" & Rows.Count).ClearContents
[B4:L4,P4:AH4].ClearContents: [N5] = ""
With Application: .ScreenUpdating = False: .Calculation = xlCalculationManual: End With
For Each Sh In ThisWorkbook.Sheets
If Sh.Name <> "Personel_Servis_Planı" Then
If Sh.AutoFilterMode Then Sh.AutoFilterMode = False
For Each XD In Sh.Range("L6:L" & Sh.Cells(Rows.Count, 12).End(3).Row)

If WorksheetFunction.CountIf([B:B], XD.Value) = 0 Then a = Cells(Rows.Count, 2).End(3).Row + 1: say = say + 1
If WorksheetFunction.CountIf([B:B], XD.Value) > 0 Then a = WorksheetFunction.Match(XD.Value, [B:B], 0)
Cells(a, 2) = XD.Value

If UCase(XD.Offset(0, -8)) = "X" Then '08:00 Güzergah Bazlı Personel Girişi
Cells(a, 4) = Cells(a, 4) + 1: Cells(4, 4) = Cells(4, 4) + 1
If UCase(XD.Offset(0, -9)) = "X" Then Cells(a, 3) = Cells(a, 3) + 1: Cells(4, 3) = Cells(4, 3) + 1 'Kreş Girişi Var
End If

If UCase(XD.Offset(0, -7)) = "X" Then '16:00 Güzergah Bazlı Personel Girişi
Cells(a, 5) = Cells(a, 5) + 1: Cells(4, 5) = Cells(4, 5) + 1
'If UCase(XD.Offset(0, -9)) = "X" Then Cells(a, 3) = Cells(a, 3) + 1: Cells(4, 3) = Cells(4, 3) + 1 'Kreş Girişi Yok
End If

If UCase(XD.Offset(0, -6)) = "X" Then '00:00 Güzergah Bazlı Personel Girişi
Cells(a, 6) = Cells(a, 6) + 1: Cells(4, 6) = Cells(4, 6) + 1
'If UCase(XD.Offset(0, -9)) = "X" Then Cells(a, 3) = Cells(a, 3) + 1: Cells(4, 3) = Cells(4, 3) + 1 'Kreş Girişi Yok
End If

'------------------------------------------------------------------------------------------


If UCase(XD.Offset(0, -5)) = "X" Then '16:00 Güzergah Bazlı Personel Çıkışı
Cells(a, 7) = Cells(a, 7) + 1: Cells(4, 7) = Cells(4, 7) + 1
'If UCase(XD.Offset(0, -9)) = "X" Then Cells(a, 3) = Cells(a, 3) + 1
End If

If UCase(XD.Offset(0, -4)) = "X" Then '18:00 Güzergah Bazlı Personel Çıkışı
Cells(a, 8) = Cells(a, 8) + 1: Cells(4, 8) = Cells(4, 8) + 1
'If UCase(XD.Offset(0, -9)) = "X" Then Cells(a, 3) = Cells(a, 3) + 1
End If

If UCase(XD.Offset(0, -3)) = "X" Then '20:00 Güzergah Bazlı Personel Çıkışı
Cells(a, 9) = Cells(a, 9) + 1: Cells(4, 9) = Cells(4, 9) + 1
'If UCase(XD.Offset(0, -9)) = "X" Then Cells(a, 3) = Cells(a, 3) + 1
End If

If UCase(XD.Offset(0, -2)) = "X" Then '00:00 Güzergah Bazlı Personel Çıkışı
Cells(a, 10) = Cells(a, 10) + 1: Cells(4, 10) = Cells(4, 10) + 1
'If UCase(XD.Offset(0, -9)) = "X" Then Cells(a, 3) = Cells(a, 3) + 1
End If

If UCase(XD.Offset(0, -1)) = "X" Then '08:00 Güzergah Bazlı Personel Çıkışı
Cells(a, 11) = Cells(a, 11) + 1: Cells(4, 11) = Cells(4, 11) + 1
'If UCase(XD.Offset(0, -9)) = "X" Then Cells(a, 3) = Cells(a, 3) + 1
End If
Next
End If
Next
son = Cells(Rows.Count, 2).End(3).Row
Range("L6:L" & son).Formula = "=IF(SUM(D6:F6)<>SUM(G6:K6),""X"","""")"
Range("L6:L" & son).Value = Range("L6:L" & son).Value:
Range("B6:L" & son).Sort [B5], 1: [N5].Activate


With Application: .ScreenUpdating = True: .Calculation = xlCalculationAutomatic: End With
ActiveSheet.Protect "1007"

End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [N5]) Is Nothing Then Exit Sub
GUZERGAH_DURAKLAR
End Sub

Sub GUZERGAH_DURAKLAR()
ActiveSheet.Unprotect "1007"
Range("M6:AH" & Rows.Count).ClearContents: [P4:AH4].ClearContents: g = [N5].Value
If [N5] = "" Then Exit Sub
With Application: .ScreenUpdating = False: .Calculation = xlCalculationManual: End With

For Each Sh In ThisWorkbook.Sheets
If Sh.Name <> "Personel Servis Planı" And Sh.Cells(Rows.Count, 11).End(3).Row > 2 Then
For Each XD In Sh.Range("L6:L" & Sh.Cells(Rows.Count, 12).End(3).Row)
If XD.Value <> "" And XD.Value = g Then

If WorksheetFunction.CountIf([N:N], XD.Offset(0, 1).Value) = 0 Then: a = Cells(Rows.Count, 14).End(3).Row + 1: Cells(a, 13) = a - 5
If WorksheetFunction.CountIf([N:N], XD.Offset(0, 1).Value) > 0 Then a = WorksheetFunction.Match(XD.Offset(0, 1).Value, [N:N], 0)
Cells(a, 14) = XD.Offset(0, 1).Value


If UCase(XD.Offset(0, -8)) = "X" Then '08:00 Durak Bazlı Personel Girişi
Cells(a, 17) = Cells(a, 17) + 1: Cells(4, 17) = Cells(4, 17) + 1
If UCase(XD.Offset(0, -9)) = "X" Then Cells(a, 16) = Cells(a, 16) + 1: Cells(4, 16) = Cells(4, 16) + 1 '08:00 Kreş Girişi
End If


If UCase(XD.Offset(0, -7)) = "X" Then '16:00 Durak Bazlı Personel Girişi
Cells(a, 18) = Cells(a, 18) + 1: Cells(4, 18) = Cells(4, 18) + 1
'If UCase(XD.Offset(0, -9)) = "X" Then Cells(a, 16) = Cells(a, 16) + 1: Cells(4, 16) = Cells(4, 16) + 1 '16:00 Kreş Girişi Yok
End If

If UCase(XD.Offset(0, -6)) = "X" Then '00:00 Durak Bazlı Personel Girişi
Cells(a, 19) = Cells(a, 19) + 1: Cells(4, 19) = Cells(4, 19) + 1
'If UCase(XD.Offset(0, -9)) = "X" Then Cells(a, 16) = Cells(a, 16) + 1: Cells(4, 16) = Cells(4, 16) + 1 '00:00 Kreş Girişi Yok
End If



If UCase(XD.Offset(0, -5)) = "X" Then '16:00
Cells(a, 22) = Cells(a, 22) + 1: Cells(4, 22) = Cells(4, 22) + 1 '16:00 DURAK ÇIKIŞ ADETLERİ
'If UCase(XD.Offset(0, -9)) = "X" Then: Cells(a, 21) = Cells(a, 21) + 1: Cells(4, 21) = Cells(4, 21) + 1 '16:00 Kreş Çıkışı Yok
End If
If UCase(XD.Offset(0, -4)) = "X" Then '18:00
Cells(a, 25) = Cells(a, 25) + 1: Cells(4, 25) = Cells(4, 25) + 1 '18:00 DURAK ÇIKIŞ ADETLERİ
If UCase(XD.Offset(0, -9)) = "X" Then: Cells(a, 24) = Cells(a, 24) + 1: Cells(4, 24) = Cells(4, 24) + 1 '16:00 Kreş Çıkışı Var
End If
If UCase(XD.Offset(0, -3)) = "X" Then '20:00
Cells(a, 28) = Cells(a, 28) + 1: Cells(4, 28) = Cells(4, 28) + 1 '20:00 DURAK ÇIKIŞ ADETLERİ
'If UCase(XD.Offset(0, -9)) = "X" Then: Cells(a, 27) = Cells(a, 27) + 1: Cells(4, 27) = Cells(4, 27) + 1 '20:00 Kreş Çıkışı Yok
End If
If UCase(XD.Offset(0, -2)) = "X" Then '00:00
Cells(a, 31) = Cells(a, 31) + 1: Cells(4, 31) = Cells(4, 31) + 1 '00:00 DURAK ÇIKIŞ ADETLERİ
'If UCase(XD.Offset(0, -9)) = "X" Then: Cells(a, 30) = Cells(a, 30) + 1: Cells(4, 30) = Cells(4, 30) + 1 '00:00 Kreş Çıkışı Yok
End If
If UCase(XD.Offset(0, -1)) = "X" Then '08:00
Cells(a, 34) = Cells(a, 34) + 1: Cells(4, 34) = Cells(4, 34) + 1 '08:00 DURAK ÇIKIŞ ADETLERİ
'If UCase(XD.Offset(0, -9)) = "X" Then: Cells(a, 33) = Cells(a, 33) + 1: Cells(4, 33) = Cells(4, 33) + 1 '08:00 Kreş Çıkışı Yok
End If

End If
Next
End If
Next
With Application: .ScreenUpdating = True: .Calculation = xlCalculationAutomatic: End With
ActiveSheet.Protect "1007"
End Sub

Sayın Okutkan
paylaştığım kod
Dosyanın kendi kod bölündeki Workbook_SheetChange kodyla tetikleniyor işlemler.

Sadece 'Güzergah Duraklar' makrosunu aşağıdaki ile değiştirip deneyin.

Size karşılaştığınız bu sorunlarla alakalı bir bilgi vereyim.
Bir koşul gerçekleştiğinde Exit Sub( kodu sonlandırma/kodun geri kalan satırların çalışmasını önleme) satırı çalışacaksa, exit sub dan önce sayfanızı şifreleme kodu yazmalısınız.
Exit sub ile kodun sonlandırılması sonucu, End sub satırından önce yazdığınız, sayfanın şifrelenmesini sağlayan kod çalışmayacağı için sayfanız şifresiz kalır.

okutkan' Alıntı:

Sadece 'Güzergah Duraklar' makrosunu aşağıdaki ile değiştirip deneyin.

Kod:

Görüntülemek için giriş yapmanız gerekmektedir.
(62 satır)

Genişletmek için tıklayın ...

Merhaba Sayın okutkan
ekteki hatayı alıyorum

verdiğini bilgi evet haklısınız ama anlamadım ilgili sayfaya geçtğimde sayfa korumalı zaten veriler yazılırken açılyor vesonra koruma devreye giriyor. kilitli hüçrelerde ısrarcı olunca sayfa korumsının açılması ilginçdi

Verdiğim kodu güncellediğeniz zaman mı hata vermeye başladı?

okutkan' Alıntı:

Verdiğim kodu güncellediğeniz zaman mı hata vermeye başladı?

Genişletmek için tıklayın ...

Evet

Yapılan işlemlerde o kadar yönlendirilen kod var ki, Yönlendirilen yerde heran exit sub ile kod sonlandırılabiliyor. Bu sonlandırma anında hangi sayfanın kilidinin açık olduğunu tespit etmek zor. Çünkü Döngü üzerinden sayfalarda tek tek işlem yapılıyor, yapılan işlem esnasında "sayfada değişiklik yapıldığında devreye giren kod" "sayfanın aktif olduğunda devreye giren kodlar" ve Çeşitli kodlar devreye giriyor. Bu kodların o anki exit sub olayında kod sonlandırılıyor, döngü içerisindeki başka bir kod içerisinde en son hangi sayfanın şifresi kaldırıldığına dair veri bulunmuyor.
Size tavsiyem, aktif sayfanın şifresini kaldırmak yerine, tüm işlemlerde bütün sayfaların şifrelerinin kaldırılıp, daha sonra bütün sayfaların şifrelenmesi.

Merhaba sayın okutkan valla ne diyim sonuna kadar haklısınız bir şekilde çözüm buluacam artık.

son olarak şunu öğrene bilirmiyim sizin sayfalar için yazdığınz Worksheet_Change kodu O4 U4 arlığındaki tarihleri her pazertesi güncellemesi gerekmiyormuydu . ben bu tarihleri her pazertesi ellemi güncelliycem

Tüm kodlardaki şifreleme ve şifre çözme satırlarını değiştirdim(Tüm sayfaların şifrelerini çözecek, tüm sayfaların şifrelerini aktif edecek şekilde). Aşağıdaki dosyayı bir deneyin.

Akif59' Alıntı:

Merhaba sayın okutkan valla ne diyim sonuna kadar haklısınız bir şekilde çözüm buluacam artık.

son olarak şunu öğrene bilirmiyim sizin sayfalar için yazdığınz Worksheet_Change kodu O4 U4 arlığındaki tarihleri her pazertesi güncellemesi gerekmiyormuydu . ben bu tarihleri her pazertesi ellemi güncelliycem

Genişletmek için tıklayın ...

Bu sorunuzla alakalı bir konu açın. Tarihlerin bulunduğu hücre aralığını konuda belirtin. Her hafta tarihlerin güncellenmesi için bir formül isteyin. Formül konusunda bilgim olmadığı için yardımcı olamıyorum.

Yukarıdaki dosya ile sorun çözüldü mü ?

okutkan' Alıntı:

Yukarıdaki dosya ile sorun çözüldü mü ?

Genişletmek için tıklayın ...

Merhaba Sayın @okutkan
evet sorun çözülmüş ama her işlemde dosya kıpır kıpır yerinde duramıyor. ortak alanda çok kullanıcılı bir dosya olacak bu
tek ben kullansam korumasız kullanıcam inanaın

Açıkcası hala 22 nolu mesajdaki dosya üzerinde sorunu arıyorum kilitli hüçrelere tıklmada ısrarcı olmak sayfa korumsunu niye kaldır anlamsız geliyor.
AMA Söyle bir şey fark ettim N7 Hüçresinde durak bazlı filtreleme yaptığımdada sorun kalkıyor.bu işlemden sonra ne kadar ısrarcı olunursa olunsun koruma kalmıyor.

İzninizle bir sorum olacak sizin yazdığınız Change kodunu tüm sayfalara kopyalamak zorundayız daha onlarca sayfa eklnecek dosyaya bunu tek birtane yapıp tüm sayfaklarda yani aktif sayfada çalşcak mantıkta yapmak mümküdür.

Tsayfalardaki haftada bir tarih güncelleme sorunu için ayrı bir konu açıcam onu sona bırakıyorum.

İzninizle bir sorum olacak sizin yazdığınız Change kodunu tüm sayfalara kopyalamak zorundayız daha onlarca sayfa eklnecek dosyaya bunu tek birtane yapıp tüm sayfaklarda yani aktif sayfada çalşcak mantıkta yapmak mümküdür.

Kodu aktif sayfada çalışacak şekilde yazdığımı hatırlıyorum. Yani şuanki haliyle kod modül içine yapıştırıp tüm sayfalarda kullanabilirsiniz. Yapamazsanız yeni konunuzda ayrıntılı sorarsınız.

Akif59' Alıntı:

Merhaba Sayın @okutkan
evet sorun çözülmüş ama her işlemde dosya kıpır kıpır yerinde duramıyor.

Genişletmek için tıklayın ...

Kodlarınız arasında çok fazla geçiş var. Ordan oraya geçiyor sürekli. Hücreye tıklamayla aktif olan, sayfa değişikliğişle aktif olan, hücre değişikliğiyle aktif olan, derken bir çok gereksiz işlem yapılıyor.