Subat ayi problem yapiyor

kaleci · 4 Aralık 2006

Sayin Hocalarim,

Subat ayinin bazen 28 gün bazen de 29 gün olmasi, benim izin cetvelinin cercevesini kaydirtiyor. Gerekli aciklamayi dosya üzerinde yaptim. Dosyayi inceleyipte yardimci olacak arkadaslara simdiden tesekkür ederim.

Saygilarimla
kaleci

kaleci · 6 Aralık 2006

Sayin arkadaslar,

Subat ayi ile ilgili Formumuza bir soru yöneltmistim. Cünkü kendi cabalarimla yapamamistim. Benim acimdan yaptigim izin cetvelinde iki eksiklik vardi birisi Subat ayi idi. Ikinciside asagidaki gördügünüz Kod ile Sayfaya izinleri otomatik olarak kaydedebiliyoruz. ComboBox1:Isim' den bir isim, ComboBox2:Isim kisaltma' dan da bir kisaltma, Datum von:Tarih baslangic(01.01.07), Datum bis: Tarih bitis (25.01.2007) seciyoruz ve sonra UF daki (Urlaub = izin) Buttonuna tikladigimizda izinler (Urlaubsplan) Sayfasina araliksiz olarak kaydediliyor.

Buraya kadar Programin nasil calistigini anlattim. Simdi de benim problemim olan yeri aciklayacagim. Sayfayi gördünüz "E4:AC399" a kadar kisaltmalarla örnegin

F,F,S,S,N,N,bos,bos) ile doludur.
Yapmak istedigim su:
Urlaub denilen buttona bastigimizda asagidaki kod ile saadece kisaltmalarin oldugu yerlere kayit yapsin ama bos olan yerlere kayit yapmasin. Yani bir arkadas hafta sonu bos ise veya N:gececilik ten sonra bos ise yine kayit yapmasin. Ne zaman calisiyorsa o zaman izin kaydetsin.

Buttona bir emir kaydetmek istedim."Eger sayfadaki hücreler bos ise izin kayit yapma", "eger sayfadaki hücreler kisaltmalarla dolu ise kayit yap".

Arkadaslar bu düsüncem sizce yapilabilecek bir düsüncemidir.

Yardimci olmak isteyen arkadaslara simdiden tesekkür ederim.
Aaaaa unutuyordum: UF de izin Buttonuna tikladiginizda Sifre sorulacaktir.
Sifreler:isim1 den isim4 e kadar: test1, isim5-isim8:test2, isim9-isim12:test3, isim13-isim16,test4, isim17-isim20:test5, isim21-isim27:test6.

Private Sub Urlaub_Click() 'Button für automatische Eintragung
Dim Kennwort As Variant
If Urlaub Then 'nur wenn Häkchen gesetzt ist
Urlaub.Value = False
If ComboBox1 = "" Then
MsgBox "Bitte wählen Sie einen Namen!", vbCritical
Exit Sub
End If
If TextBox1 = "" Or TextBox2 = "" Then
MsgBox "Bitte geben Sie Datum ein!", vbCritical
Exit Sub
End If
Datum1 = TextBox1 'veya DTPicker1
Datum2 = TextBox2 'veya DTPicker2
Finden1 = Range("C3:C399").Find(Datum1, LookIn:=xlValues).Row
Finden2 = Range("C3:C399").Find(Datum2, LookIn:=xlValues).Row
Set s2 = Tabelle4
Kennwort = Array(s2.[b2], s2.[b3], s2.[b4], s2.[b5], _
s2.[b6], s2.[b7], s2.[b8], s2.[b9], s2.[b10], s2.[b11], s2.[b12], _
s2.[b13], s2.[b14], s2.[b15], s2.[b16], s2.[b17], s2.[b18], _
s2.[b19], s2.[b20], s2.[b21], s2.[b22], s2.[b23], s2.[b24], _
s2.[b25], s2.[b26], s2.[b27], s2.[b28]) '"3xtest" ist Reserve. Bei neue Eintrag wird erweitert
If Kennwort(ComboBox1.ListIndex) = PasswordAbfrage Then
Range(Cells(Finden1, Spalte1), Cells(Finden2, Spalte1)).Value = ComboBox2
Range(Cells(Finden1, Spalte1), Cells(Finden2, Spalte1)).Interior.ColorIndex = 4
For Each nesne In Controls 'TextBox leeren
If TypeName(nesne) = "TextBox" Then 'TextBox leeren
nesne.Value = "" 'TextBox leeren
End If 'TextBox leeren
Next nesne 'TextBox leeren
Else
MsgBox "Passwort falsch!!!"
End If
End If
End Sub

Saygilarimla
kaleci

kaleci · 6 Aralık 2006

Sorumla ilgilenen Arkadaslar,

yarim adim daha ilerleyebildim. Sonuca ulasmamiz acisindan sizlerede faidesi olur diye cözümünü buldugum Formülü asagiya yazdim. Subat ayi 28 olunca 63. Hücreyi bos birakmayi becerebildim. Düsündügüm gibi mart ayi 64. Satirdan basliyor.
Formülü su sekilde degistirdim.
63. Hücreye =WENN(MONAT(C62+1)=MONAT(C62);C62+1;"") yazdim, 64. Hücreye=DATUM($C$1;3;1), 65. Hücreyede =C64+1 yazdim ve istedigim gibi oldu.

Simdi sira geldi Makroyu degistirmeye:
Arkadaslar: Söyle bir emri (dreifachschicht) isimli Makroya nasil ekleriz?.
(Eger 63. Hücre bos ise, vardiye kisaltmalarini 63.Satira yazma, bir sonraki satirdan yazmaya devam et. Dolu olunca zaten yaziyor, bir problem yok.

Saygilarimla
kaleci

kaleci · 7 Aralık 2006

Merhaba Hocalarim ve arkadaslarim,

Cok sasiracaksiniz, ilkdefa böylebir sey oluyor sanirim. Kendim sordum kendim cevapliyorum. En sonunda sonuca ulasabildim. Cok mutluyum. Denerken denerken en sonunda oldu ama epeyce ugrastim.
Degisikligi asagidaki gibi yapiniz.

Sub dreifachschicht()
On Error Resume Next
Application.ScreenUpdating = False
Set s1 = Sheets("Urlaubsplan")
dega = Array("N", "", "", "F", "F", "S", "S", "N", "N")
degb = Array("S", "N", "N", "", "", "F", "F", "S", "S")
degc = Array("F", "S", "S", "N", "N", "", "", "F", "F")
degd = Array("", "F", "F", "S", "S", "N", "N", "", "")
For a = 4 To 400
fark = (s1.Cells(a, "c") - DateSerial(2006, 1, 1)) / 8
s1.Range(Cells(a, "e"), s1.Cells(a, "h")) = dega((fark - Int(fark)) * 8)
s1.Range(Cells(a, "i"), s1.Cells(a, 12)) = degb((fark - Int(fark)) * 8)
s1.Range(Cells(a, "m"), s1.Cells(a, "p")) = degc((fark - Int(fark)) * 8)
s1.Range(Cells(a, "q"), s1.Cells(a, "t")) = degd((fark - Int(fark)) * 8)
Next
If Range("B63") = "" Then Range("E63:AE63") = ""
Application.ScreenUpdating = True
End Sub

Saygilarimla
kaleci