• DİKKAT

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

Kura

Y

Yesilyurtlu

Katılım
22 Mayıs 2009
Mesajlar
1,017
Excel Vers. ve Dili
Office 2003
Değerli Uzmanlarım;
Ekli dosya için yardımlarınızı istirham ediyorum.
Teşekkür ederim
 

Ekli dosyalar

Merhaba,

Alternatif olsun.

Kod: 
Sub Kura_Cek()
    
    Dim ShLst   As Worksheet, _
        ShFrm   As Worksheet, _
        Adt     As Integer, _
        i       As Integer, _
        Son     As Integer, _
        CekNo   As Integer, _
        c       As Range
        
    Application.ScreenUpdating = False
    
    Set ShLst = Sheets("Liste")
    Set ShFrm = Sheets("Form")
    
    i = ShLst.Cells(Rows.Count, "B").End(3).Row
    ShFrm.Range("C10:F" & i).ClearContents
    Adt = ShFrm.Range("F1")
    Son = ShLst.Cells(Rows.Count, "B").End(3).Row - 1
    
    Randomize (CDbl(Now))
    
    i = 1
    
    Do While Not i > Adt
        Do
            CekNo = Int((Son * Rnd) + 1)
            Set c = ShFrm.Range("C10:C" & 9 + i).Find(ShLst.Cells(CekNo + 1, "B"), LookIn:=xlValues, LookAt:=xlWhole)
        Loop While Not c Is Nothing
                
        ShFrm.Cells(i + 9, "C") = ShLst.Cells(CekNo + 1, "B")
        ShFrm.Cells(i + 9, "D") = ShLst.Cells(CekNo + 1, "C")
        
        i = i + 1
    Loop
    
    ShFrm.Range("C10:D" & 8 + i).Sort Key1:=ShFrm.[C1]
    
    Application.ScreenUpdating = True
    
End Sub

Kod: 
Sub Aktar()
    
    Dim i       As Integer, _
        ShFrm   As Worksheet
        
    Set ShFrm = Sheets("Form")
    
    Application.ScreenUpdating = False
    
    ShFrm.Copy After:=Sheets(Sheets.Count)
    ActiveSheet.Name = "Kura-" & ShFrm.Range("F1")
    ActiveSheet.DrawingObjects.Delete
    
    ShFrm.Select
    i = ShFrm.Cells(Rows.Count, "B").End(3).Row
    ShFrm.Range("C10:F" & i).ClearContents
    
    Application.ScreenUpdating = True
    
End Sub
 

Ekli dosyalar

Değerli ağabeyim muokumus ve sevgili uzmanım Necdet Yeşertener abim İstediğim gibi olmuş ellerinize sağlık.
Teşekkür ederim
 
Üstadlarım;
bayağı bir kura çekme yaptım Mükerrer isim oluyor listeler arasında.Bunun bir çözümü varmıdır?
 
Muhtemelen size Hocam. Çünkü siz sayfa adını hücre değerine göre vermişsiniz. Aynı değerde birden fazla kura çekiminde hata veriyor.
 
muokumus' Alıntı:
Muhtemelen size Hocam. Çünkü siz sayfa adını hücre değerine göre vermişsiniz. Aynı değerde birden fazla kura çekiminde hata veriyor.
Genişletmek için tıkla ...


Hiç bir şey anlamadım :)

Ben deniyorum mükerrer kayıt yok.

Ama her çekilişte yeni sayfa oluştur diyor arkadaşamız, o da kontrol edilecek mi ? öyle bir kanıya varmadım.
 
Hocam yeni sayfa ekliyorusunuz. Orda bir sorun. Örneğin iki kez aynı sayıda öğretmen görev alırsa hata veriyor.
 
muokumus' Alıntı:
Hocam yeni sayfa ekliyorusunuz. Orda bir sorun. Örneğin iki kez aynı sayıda öğretmen görev alırsa hata veriyor.
Genişletmek için tıkla ...

Ben onu kontrol etmedim, öyle bir istek yoktu çünkü :)

Ama sizin dediğinizi sizin dosyanızda kontrol ettim, mükerrerlik sizde de oluşuyor. Form Sayfasında değil ama Form ile başlayan diğer sayfalarda olan bir kişi Form sayfasındaki kurada da çıkabiliyor.

Bu normal çünkü böyle bir istek yok. Yani ikimizin de yaptığı doğru. Tabi soruya göre, sayın yeşilyurtlu'nun kafasından geçene göre değil :)
 
Hocam benim bahsettiğim mükerrer kişi adlarında değil, sayfa adlarında. Aynı adı taşıyan iki sayfa oluşturuyor. Buda hata veriyor.
 
Merhaba,

Kurada görevlendirilecek bir kaç grup oluşturulacaksa kodları aşağıdaki şekilde değiştirdim.

Liste sayfasında D sütununda Durumu saptayacak yani daha önce kurada çıkıp çıkmadığını kontrol edecek Sütun ekledim.

Başlangıçta bu sütunun değeri boş olmalı. Kuruda çıkan kişinin karşısına "Görevlendirildi" ibarese eklenecek.

Dolayısıyla kura grupları arasında aynı kişi değişik gruplarda olmayacak.

Bakalım bu çözüm için yorum nasıl olacak?

Kod: 
Sub Kura_Cek()
 
    Dim ShLst   As Worksheet, _
        ShFrm   As Worksheet, _
        Adt     As Integer, _
        i       As Integer, _
        Son     As Integer, _
        CekNo   As Integer, _
        Bos     As Integer, _
        Durum   As Boolean
 
    Application.ScreenUpdating = False
 
    Set ShLst = Sheets("Liste")
    Set ShFrm = Sheets("Form")
 
    i = ShLst.Cells(Rows.Count, "B").End(3).Row
    ShFrm.Range("C10:F" & i).ClearContents
    Adt = ShFrm.Range("F1")
    Son = ShLst.Cells(Rows.Count, "B").End(3).Row - 1
    Bos = Application.WorksheetFunction.CountBlank(ShLst.Range("D2:D" & i))
 
    If Adt > Bos Then
        MsgBox "Boşta Kalan Görevli Sayısı : " & Bos & Chr(10) & Chr(10) & _
               " Sizin İstediğiniz Görevli Adedi : " & Adt & Chr(10) & Chr(10) & _
               "İSTEDİĞİNİZİ GERÇEKLEŞTİREMİYECEĞİM....."
        Exit Sub
    End If
 
    Randomize (CDbl(Now))
 
    i = 1
 
    Do While Not i > Adt
        Durum = False
        Do
            CekNo = Int((Son * Rnd) + 1)
            If ShLst.Cells(CekNo + 1, "D") = "" Then
                Durum = True
                ShLst.Cells(CekNo + 1, "D") = [B][COLOR=red]ShFrm.Range("D3")[/COLOR][/B]
            End If
'            Set c = ShFrm.Range("C10:C" & 9 + i).Find(ShLst.Cells(CekNo + 1, "B"), LookIn:=xlValues, LookAt:=xlWhole)
        Loop While Not Durum = True
 
        ShFrm.Cells(i + 9, "C") = ShLst.Cells(CekNo + 1, "B")
        ShFrm.Cells(i + 9, "D") = ShLst.Cells(CekNo + 1, "C")
 
        i = i + 1
    Loop
 
    ShFrm.Range("C10:D" & 8 + i).Sort Key1:=ShFrm.[C1]
    MsgBox "KURA ÇEKİLMİŞTİR...", vbInformation, "Necdet YEŞERTENER --> excel.web.tr"
    Application.ScreenUpdating = True
 
End Sub

Kod: 
Sub Aktar()
 
    Dim i       As Integer, _
        Adet    As Integer, _
        ShFrm   As Worksheet, _
        Sh      As Worksheet
 
    Set ShFrm = Sheets("Form")
 
    Application.ScreenUpdating = False
 
    For Each Sh In Worksheets
        If Sh.Name Like "Kura*" Then Adet = Adet + 1
    Next Sh
 
    Adet = Adet + 1
 
    ShFrm.Copy After:=Sheets(Sheets.Count)
    ActiveSheet.Name = "Kura-" & Adet
    ActiveSheet.DrawingObjects.Delete
 
    ShFrm.Select
    i = ShFrm.Cells(Rows.Count, "B").End(3).Row
    ShFrm.Range("C10:F" & i).ClearContents
 
    Application.ScreenUpdating = True
 
End Sub
 

Ekli dosyalar

Necdet abi
Ellerine sağlık Zahmet verdim size Özür dilerim.
Yardımlarınızı esirgemediğiniz için TEŞEKKÜR EDERİM.
Allah Razı Olsun
 
Yesilyurtlu' Alıntı:
Necdet abi
Ellerine sağlık Zahmet verdim size Özür dilerim.
Yardımlarınızı esirgemediğiniz için TEŞEKKÜR EDERİM.
Allah Razı Olsun
Genişletmek için tıkla ...

Zahmet değil de olayı anlamak önemli.

Son durum isteğinizi karşılıyor mu ? yorum yapmadınız.
 
Necdet abi;
21//01/2012 - 22/01/2012 tarihleri arasında Açık Öğretim Lisesi Sınavı var.
üç dört işin arasındabBu sınava görevlendirme yapabilmek karmaşık bir hal alıyordu. Hata vermemek mümkün değildi. En son eklediğiniz makro ile "Allah Ahiretinizi cennet eyleye inşallah" bu yükün altında rahatlıkla çıkacağım. Program da mükerrer olayı göremedim. Şu an için mükemmel abi. İstediğimden de güzel olmuş.
Zamanınızı bana ayırdınız Allah razı olsun Necdet abi. Çok çok sağolasın abi
 
Yesilyurtlu' Alıntı:
Necdet abi;
21//01/2012 - 22/01/2012 tarihleri arasında Açık Öğretim Lisesi Sınavı var.
üç dört işin arasındabBu sınava görevlendirme yapabilmek karmaşık bir hal alıyordu. Hata vermemek mümkün değildi. En son eklediğiniz makro ile "Allah Ahiretinizi cennet eyleye inşallah" bu yükün altında rahatlıkla çıkacağım. Program da mükerrer olayı göremedim. Şu an için mükemmel abi. İstediğimden de güzel olmuş.
Zamanınızı bana ayırdınız Allah razı olsun Necdet abi. Çok çok sağolasın abi
Genişletmek için tıkla ...

Güle güle kullanınız.
 
Necdet abi ;
Kızmazsanız bir değişiklik isteyebilir miyim.
Liste sayfasında durum sütununa görevlendirildi yerine Form sayfasında yer alan sınav binasının adı yazılabilir mi?
Örneğin :Liste sayfasında yer alan
adı soyadı
Adı Soyadı 006
Görev Yeri
Görev Yeri 006
Durum
(Form sayfasında Sınav Binasının Adı kısmında ne yazılı ise onu yazsa)

Böyle mükerrer kontrolü yapsa olur mu?
 
Yesilyurtlu' Alıntı:
Necdet abi ;
Kızmazsanız bir değişiklik isteyebilir miyim.
Liste sayfasında durum sütununa görevlendirildi yerine Form sayfasında yer alan sınav binasının adı yazılabilir mi?
Örneğin :Liste sayfasında yer alan
adı soyadı
Adı Soyadı 006
Görev Yeri
Görev Yeri 006
Durum
(Form sayfasında Sınav Binasının Adı kısmında ne yazılı ise onu yazsa)

Böyle mükerrer kontrolü yapsa olur mu?
Genişletmek için tıkla ...

Rica ederim. 13. mesajımdaki kodları ve dosyayı yeniledim.
Koddaki değişikliği kırmızı ile belirttim.
 
Necdet Abi Hakkını Helal Et
Değişiklik Talebimi kırmadığınız için Teşekkür ederim
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst