• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

Personele aynı tarihlerde tek iş vermek..

S.Yiğit

S.Yiğit

Destek Ekibi
Destek Ekibi
Katılım
1 Temmuz 2008
Mesajlar
1,748
Excel Vers. ve Dili
2019 TR
Merhaba,

Her satır bir servis işi oluyor. O servise gidecek personeli O ile X sutunu aralığına giriyoruz. Servise verilecek personel sayısı belli olmaz 1'de olabilir 10'da olabilir. En fazla 10 personel verilir. Yapmak istediğimiz personele aynı tarihlerde ikinci işi vermemek. . Sadece uyarı istiyoruz. Engelleme değil.
Eki incelerseniz daha basit anlarsınız.. Yardımlarınız için teşekkürler..
 

Ekli dosyalar

Herkese günaydın,

Yukarıdaki konuda yardım rica ediyorum.. Teşekkürler..
 
Merhaba,

Soruyu anlatamadım mı acaba?
 
Merhaba,

Soruyu anlatamadım mı acaba?
 
Yukarıdaki konuda hala ısrarcıyım :)
 
Ben hala ısrarcıyım. Bu sorunu çözmen lazım :)
 
Selamlar,

Daha öncede buna benzer bir sorunuz vardı. Onda önerdiğim kodu biraz revize ettim. Aşağıdaki kodu sayfanızın kod bölümüne uygulayıp denermisiniz.

Siz kodun I-J-M sütunları değiştiğinde çalışmasını istemişsiniz. Ben O-X arası değiştiğinde çalışacak şekilde ayarladım.

Sizin belirttiğiniz sütunlar değiştiğinde de kod çalışabilir. Fakat diyelimki 9. satırdaki tarihleri değiştirdiniz. Bu satırda birden fazla isim girilmiş durumda. Ve birden fazla personele daha önceden iş planlaması yapılmış olduğunu varsayalım. Makro size hangisi için uyarı vermeli?

Kod: 
Option Explicit
 
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim BUL As Range, ADRES As String, TARİH As Date, KONTROL As Boolean
 
    If Intersect(Target, Range("O3:X65536")) Is Nothing Then Exit Sub
 
    If Cells(Target.Row, "I") <> "" And Cells(Target.Row, "J") <> "" Then
        Set BUL = Range("O2:X" & Target.Row - 1).Find(Target, LookAt:=xlWhole)
        If Not BUL Is Nothing Then
        ADRES = BUL.Address
        Do
            For TARİH = Cells(Target.Row, "I") To Cells(Target.Row, "J")
                If TARİH >= Cells(BUL.Row, "I") And TARİH <= Cells(BUL.Row, "J") Then
                    KONTROL = True
                    Exit For
                End If
            Next
 
            If KONTROL = True Then
                MsgBox Target & " isimli personel için daha önce " & TARİH & " tarihinde iş planlaması yapılmıştır !" & Chr(10) & _
                "Aynı personele benzer tarih aralığında yeni iş planlaması yapamazsınız !" & Chr(10) & "Lütfen kontrol ediniz !", vbCritical
                Exit Do
            End If
        Set BUL = Range("O2:X" & Target.Row - 1).FindNext(BUL)
        Loop While Not BUL Is Nothing And BUL.Address <> ADRES
        End If
    End If
End Sub
 
Merhaba hocam, öncelikle teşekkür ederim.

Kodun I-J-M sütunları değiştiğinde çalışmasını istedim çünkü tarihlerde revize yapabiliyoruz, daha erkene alabiliyoruz veya daha geç tarihe.. Bizim sıkıntımız servis planımıza göre personelleri servislere dağıtmak.. Örnek personel 15 şubat 2011 tarihinde 2 günlük servise gidecek diyelim yani 15 ve 16 şubatta çalışıyor bu tarihlerde başka iş verilirse uyarı vermeli.. iş 16 şubatta bittiği için 17'sinde yeni işe gidebilir.

Gönderdiğim çalışmada P7 sütunundayken f2 enter yaptığımızda uyarıyı veriyor.. Daha sonra O6 hücresinde aynı işlemi yaptığımızda uyarı vermiyor, vermeli çünkü 4 ve 5 şubatta personelin işi var( P7 hücresi O.Akdeniz)
Bir örnek daha vereyim P6 hücresine L.Yay yazdığımda uyarı vermiyor vermeli çünkü 4 ve 5 şubatta işi var (O7 hücresi)

I-J-M ve O - X sütunu aralığında değerler değiştiğinde makro çalışsın ve aynı tarihlerde iş verlen personelleri yazsın yeter. Örnek: "Aynı tarihlerde iş planlanan personeller: L.Yay O.Akdeniz " gibi.. Tarih veya hücre belirtmesine gerek yok.
 

Ekli dosyalar

Selamlar,

Aşağıdaki kodu denermisiniz.

Kod: 
Option Explicit
 
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim BUL As Range, ADRES As String, TARİH As Date, KONTROL As Boolean
    Dim X As Byte, Y As Byte, PERSONEL_ADI As String, İSİM_KONTROL() As String
    
    If Intersect(Target, Range("I3:I65536,M3:M65536,O3:X65536")) Is Nothing Then Exit Sub
    If Target.Cells.Count > 1 Then Exit Sub
    
    If Target.Column <= 13 Then
        For X = 15 To 24
            If Cells(Target.Row, X) <> "" Then
                Set BUL = Range("O2:X65536").Find(Cells(Target.Row, X), LookAt:=xlWhole)
                If Not BUL Is Nothing Then
                ADRES = BUL.Address
                Do
                    If BUL.Row = Target.Row Then GoTo Devam1
                    For TARİH = Cells(Target.Row, "I") To Cells(Target.Row, "J")
                        If TARİH >= Cells(BUL.Row, "I") And TARİH <= Cells(BUL.Row, "J") Then
                            If PERSONEL_ADI <> "" Then
                                İSİM_KONTROL = Split(PERSONEL_ADI, Chr(10))
                                For Y = 0 To UBound(İSİM_KONTROL())
                                    If İSİM_KONTROL(Y) = Cells(Target.Row, X) Then
                                        KONTROL = True
                                    End If
                                Next
                                
                                If KONTROL = False Then PERSONEL_ADI = PERSONEL_ADI & Chr(10) & Cells(Target.Row, X)
                            
                            Else
                                
                                PERSONEL_ADI = PERSONEL_ADI & Chr(10) & Cells(Target.Row, X)
                            End If
                        End If
                        KONTROL = False
                    Next
Devam1:
                Set BUL = Range("O2:X65536").FindNext(BUL)
                Loop While Not BUL Is Nothing And BUL.Address <> ADRES
                End If
            End If
        Next
        
        If PERSONEL_ADI <> "" Then
            MsgBox "Aşağıdaki personeller için daha önce girdiğiniz tarih aralığında iş planlaması yapılmıştır !" & Chr(10) & _
            "Aynı personellere benzer tarih aralığında yeni iş planlaması yapamazsınız !" & Chr(10) & _
            "Lütfen kontrol ediniz !" & Chr(10) & PERSONEL_ADI, vbCritical
        End If
    
    Else
        
        If Cells(Target.Row, "I") <> "" And Cells(Target.Row, "J") <> "" And Target <> "" Then
            Set BUL = Range("O2:X65536").Find(Target, LookAt:=xlWhole)
            If Not BUL Is Nothing Then
            ADRES = BUL.Address
            Do
                If BUL.Row = Target.Row Then GoTo Devam2
                For TARİH = Cells(Target.Row, "I") To Cells(Target.Row, "J")
                    If TARİH >= Cells(BUL.Row, "I") And TARİH <= Cells(BUL.Row, "J") Then
                        KONTROL = True
                        Exit For
                    End If
                Next
                
                If KONTROL = True Then
                    MsgBox Target & " isimli personel için daha önce " & TARİH & " tarihinde iş planlaması yapılmıştır !" & Chr(10) & _
                    "Aynı personele benzer tarih aralığında yeni iş planlaması yapamazsınız !" & Chr(10) & "Lütfen kontrol ediniz !", vbCritical
                    Exit Do
                End If
Devam2:
            Set BUL = Range("O2:X65536").FindNext(BUL)
            Loop While Not BUL Is Nothing And BUL.Address <> ADRES
            End If
        End If
    End If
End Sub
 
Hocam, bu sefer ne girersem girim uyarı veriyor. :) İlk defa yazdığıma bile veriyor. Birde Personelleri temizleyip baştan planladığımda kırmıza boyadığım yerde hata veriyor.

If KONTROL = True Then
MsgBox Target & " isimli personel için daha önce " & TARİH & " tarihinde iş planlaması yapılmıştır !" & Chr(10) & _
"Aynı personele benzer tarih aralığında yeni iş planlaması yapamazsınız !" & Chr(10) & "Lütfen kontrol ediniz !", vbCritical
Exit Do
 

Ekli dosyalar

Selamlar,

Üstteki mesajımdaki kodu güncelledim. İncelermisiniz.
 
Hocam yine olmadı malesef.. :( Personelin tamamını silip O3'e Serkan yazalım enterlayıp O4'e geçelim yine serkan yazalım uyarı geliyor.. personeli ilk kez nerde yazarsak yazalım uyarı vermiyor ama ikinci kez nerde yazarsak yazalım uyarı veriyor.

Bide personelleri silince aşağıdaki hata geliyor. (hücreleri tek tek silince sorun yok ama topluca silince hata veriyor.)

Else

If Cells(Target.Row, "I") <> "" And Cells(Target.Row, "J") <> "" And Target <> "" Then
Set BUL = Range("O2:X65536").Find(Target, LookAt:=xlWhole)
 

Ekli dosyalar

Selamlar,

#9 nolu mesajımdaki kodu güncelledim. İncelermisiniz.
 
Hocam merhaba, Gece 1,5'da cevap vermişsiniz, teşekkür ederim.

O6 hücresine serkan yazalım sonra O7 serkan yazalım uyarı geliyor ama tam tersini yazınca gelmiyor gelmesi lazım.. Sorun bende galiba ben sorunumu anlatamıyorum. Derdim aynı tarihlerde personele ikinci tarihi vermemek.

Hocam bu konuya şimdilik ara verelim.. Halit hocamın yardımcı olduğu bir çalışması var, başka sayfada boyama yaparken orda iki iş verilmişse farklı renge boyuyordu. Bu çalışmayada aynısını yapacağım ama sayfayı düzenlemem lazım.. Sizide uğraştırdım, çok teşekkür ederim.
 

Ekli dosyalar

Son düzenleme:
Selamlar,

#9 nolu mesajımdaki kodu tekrar güncelledim. İncelermisiniz.
 
Hocam günaydın,

Bu sefer olmuş hatta çok güzel olmuş, :) elinize sağlık.. Müsait olduğunuzda aşağıdaki konuyada bakabilirseniz çok sevinirim.. Aşağıdaki işi manuel yapıyorum ve çok zamanımı alıyor.. Çok teşekkürler..

Çalışma tablosunda boyama yapmak
 
Korhan bey merhaba,

9 nolu mesajdaki kodunuzu kullanıyorum. yanlız bu sene bölge bölge plan yapıyoruz. Filtre varsa kod çalışmıyor. Bu konuda yardımcı olabiliyor musunuz? Örnek eklicem ama çok karışık bir tablo var.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst