Listeyi bir sütundaki kritere göre rastgele dağıtmak

abkbek · 5 Kasım 2009

Arkadaşlar merhaba,
Excel'de oluşturduğum iki sütunlu bir liste var, bu listenin birinci sütununda bulunan değerleri ikinci sütundaki kritere göre belirli sayıda gruplara rastgele dağıtmak istiyorum. bu konuda hazırladığım örnek çalışma ektedir.
sayın üstadlarımın mutlaka bir çözüm bulacaklarını biliyorum. ekte daha detaylı açıklama ve manuel olarak yapılmış bir örnek sayfa yer almaktadır.

Korhan Ayhan · 5 Kasım 2009

Selamlar,

Aşağıdaki kodu denermisiniz.

Kod:

Option Explicit
 
Sub DERS_DAĞILIMI()
    Dim Say As Long, Sayı As Integer
    Dim Satır As Integer, Sütun As Byte, WF As WorksheetFunction
 
    Set WF = WorksheetFunction
 
    Range("D2:K65536").Clear
    Say = WF.Sum(Range("B:B"))
    Satır = 2
    Sütun = 4
 
    Randomize
 
Başla:
    Sayı = Int((101 * Rnd) + 1)
 
    If Sayı > 1 Then
        If Satır > Range("N1") + 1 Then
            Columns(Sütun).Sort Key1:=Cells(1, Sütun), Order1:=xlAscending, Header:=xlGuess, _
            OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortTextAsNumbers
            Satır = 2
            Sütun = Sütun + 1
        End If
 
        If WF.CountIf(Columns(Sütun), Cells(Sayı, 1)) > 0 Or WF.CountIf(Columns(Sütun - 1), Cells(Sayı, 1)) > 0 Then GoTo Başla
 
        Cells(Satır, Sütun) = Cells(Sayı, 1)
 
        If WF.CountIf(Range("D2:K65536"), Cells(Sayı, 1)) = Cells(Sayı, 2) Then
            Cells(Satır, Sütun).Interior.ColorIndex = 1
            Cells(Satır, Sütun).Font.ColorIndex = 2
        End If
        Satır = Satır + 1
    End If
 
    If WF.CountA(Range("D2:K65536")) <> Say Then GoTo Başla
 
    Set WF = Nothing
 
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

abkbek · 5 Kasım 2009

Sayın Korhan Ayhan,
Çok ama çok teşekkür ederim, emeğinize ve aklınıza sağlık,
acaba bu dağılımı tamamladıktan sonra her bir ders grubunu kendi içerisinde artan sıralama olacak şekilde düzenlemek için ayrı bir komut düğmesi mi hazırlamalıyım, yoksa kodun arkasına bu da ilave edilebilir mi?

Korhan Ayhan · 5 Kasım 2009

Selamlar,

Üstteki mesajımdaki kodu güncelledim. İncelermisiniz.

abkbek · 5 Kasım 2009

Sayın Koryan Ayhan,
Çok teşekkür ederim, hızır gibi yetişiyorsunuz.
başlangıçta düşünemediğim bazı ayrıntılar şimdi aklıma geliyor, acaba kayıt sayısını ve derse girecek kayıt sayı miktarını koda her seferinde kendimiz yazmak yerine başlamadan önce A sütunundaki kayıt sayısını kod ile sayıp, daha sonra N1 hücresindeki (derse girecek miktarı gösteren hücre) değer kadar gruplar rastgele oluşturulsun, (Yani kod içerisinde sabit sayılar yerine belirtilen hücrelerdeki değeri alması şeklinde) tabi bu durumda oluşturulacak ders grup sayısı da artabilecek yada azalabilecek yani 8 ders sabit olmayacak.
bir de gruplara dağılım yapılırken birinci derste yeralan bir kaydın kendinden bir sonraki grupta geçmemesi şartını kendinden sonraki ikinci ve üçüncü ders şeklinde düzeltmem mümkün müdür?
Lütfen bir cevap verdim yakamı kurtaramıyorum şeklinde yorumlamayınız sorularımı, böyle düşünmenizi hiç arzu etmem, inanın günlerdir çözümü kendi başıma bulmaya çalıştım ancak bir türlü bulamadım,

abkbek · 8 Kasım 2009

Sayın Korhan Ayhan,
sorumla ilgilenebilirseniz memnun olurum.

abkbek · 8 Kasım 2009

Sayın Korhan Ayhan,
iyi günler diliyorum....

Korhan Ayhan · 9 Kasım 2009

Selamlar,

Aşağıdaki kodu denermisiniz. Veri tekrarlarını kontrol ederken 3 ve sonrası için değer girerseniz döngü uzadığı için kodlar sizi bekletecektir. Bu sebeple maksimum 2 değerini girmenizi öneririm.

Kod:

Option Explicit
 
Sub DERS_DAĞILIMI()
    Dim KAYIT_SATIR_SAYISI As Long, TOPLAM_DERS_SAYISI As Long
    Dim SAYAÇ As Byte, KONTROL As Integer, SATIR As Long, SÜTUN As Byte, YENİ_SATIR As Long, İLK_SÜTUN As Byte
    Dim DERSE_GİRECEK_MİKTAR As Integer, DERS_GRUP_SAYISI As Integer, DERS_GRUP_TEKRAR_SAYISI As Byte
    Dim ADRES1 As String, ADRES2 As String, X As Byte, ÜRETİLEN_SAYI As Long, WF As WorksheetFunction
 
    Set WF = WorksheetFunction
 
    KAYIT_SATIR_SAYISI = Range("A65536").End(3).Row
    TOPLAM_DERS_SAYISI = WF.Sum(Range("B:B"))
 
    Range("C:IV").Clear
 
    SATIR = Val(Application.InputBox("Listeniz hangi satırdan itibaren oluşturulsun?", , 1))
    If SATIR <= 0 Then Exit Sub
 
    SÜTUN = Val(Application.InputBox("Listeniz hangi sütundan itibaren oluşturulsun?", , 4))
    If SÜTUN <= 0 Then Exit Sub
 
    DERSE_GİRECEK_MİKTAR = Val(Application.InputBox("Derse girecek miktarı giriniz.", , 30))
    If DERSE_GİRECEK_MİKTAR <= 0 Then Exit Sub
 
    DERS_GRUP_SAYISI = Val(Application.InputBox("Ders grup sayısını giriniz.", , 8))
    If DERS_GRUP_SAYISI <= 0 Then Exit Sub
 
    DERS_GRUP_TEKRAR_SAYISI = Val(Application.InputBox("Ders kendinden önce kaç grupta tekrarlanmasın?", , 1))
    If DERS_GRUP_TEKRAR_SAYISI <= 0 Then Exit Sub
 
    If (DERSE_GİRECEK_MİKTAR * DERS_GRUP_SAYISI) < TOPLAM_DERS_SAYISI Then
        MsgBox "Girdiğiniz DERS GRUP SAYISI tüm kayıtları listelemek için uygun değildir." & Chr(10) & Chr(10) & _
        "Uygun grup sayısı : " & WF.RoundUp(TOPLAM_DERS_SAYISI / DERSE_GİRECEK_MİKTAR, 0) & Chr(10) & Chr(10) & _
        "İşleminiz iptal edilmiştir.", vbCritical, "Dikkat !"
        Exit Sub
    End If
 
    ADRES1 = Range(Cells(SATIR, SÜTUN), Cells(65536, SÜTUN + DERS_GRUP_SAYISI - 1)).Address
    ADRES2 = Range(Cells(SATIR + 1, SÜTUN), Cells(65536, SÜTUN + DERS_GRUP_SAYISI - 1)).Address
 
    For X = SÜTUN To SÜTUN + DERS_GRUP_SAYISI - 1
        SAYAÇ = SAYAÇ + 1
        Cells(SATIR, X) = SAYAÇ & ". Ders"
        Cells(SATIR, X).Font.Bold = True
    Next
 
    SATIR = SATIR + 1
    YENİ_SATIR = SATIR
 
    Randomize
 
BAŞLA:
 
    ÜRETİLEN_SAYI = Int((KAYIT_SATIR_SAYISI * Rnd) + 1)
 
    KONTROL = 0
 
    If ÜRETİLEN_SAYI > 1 Then
        If (YENİ_SATIR - SATIR + 2) > DERSE_GİRECEK_MİKTAR + 1 Then
[COLOR=red]            Range(Cells(SATIR, SÜTUN), Cells(DERSE_GİRECEK_MİKTAR, SÜTUN)).Sort Key1:=Cells(SATIR, SÜTUN), Order1:=xlAscending, Header:=xlGuess, _[/COLOR]
[COLOR=red]            OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortTextAsNumbers[/COLOR]
            YENİ_SATIR = SATIR
            SÜTUN = SÜTUN + 1
        End If
 
        If SÜTUN < DERS_GRUP_TEKRAR_SAYISI Then
            İLK_SÜTUN = 1
            Else
            İLK_SÜTUN = SÜTUN - DERS_GRUP_TEKRAR_SAYISI
        End If
 
        For X = İLK_SÜTUN To SÜTUN
            If X > 1 Then KONTROL = KONTROL + WF.CountIf(Columns(X), Cells(ÜRETİLEN_SAYI, 1))
        Next
 
        If KONTROL > 0 Then GoTo BAŞLA
 
        Cells(YENİ_SATIR, SÜTUN) = Cells(ÜRETİLEN_SAYI, 1)
 
        If WF.CountIf(Range(ADRES1), Cells(ÜRETİLEN_SAYI, 1)) = Cells(ÜRETİLEN_SAYI, 2) Then
            Cells(YENİ_SATIR, SÜTUN).Interior.ColorIndex = 1
            Cells(YENİ_SATIR, SÜTUN).Font.ColorIndex = 2
        End If
        YENİ_SATIR = YENİ_SATIR + 1
    End If
 
    If WF.CountA(Range(ADRES2)) <> TOPLAM_DERS_SAYISI Then GoTo BAŞLA
 
    Set WF = Nothing
 
    Cells.EntireColumn.AutoFit
 
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

abkbek · 9 Kasım 2009

Sayın Üstadım Korhan Ayhan,
Çok ama çok teşekkür ederim. çok önemli değil ama bu bile fazlasıyla işimi görür ancak sıralamayı tercihli hale getirmek mümkün müdür, yada sıralamaları (grupların kendi içlerindeki)istediğim zaman yapmak için nerede değişiklik yapmalıyım.
Emeğinize ve aklınıza sağlık, inanın bu kodu her kullandığımda sizi minnetle anacağım.
tüm hayatınızda sağlık, mutluluk ve huzurlu günler geçirmenizi en içten duygularımla temenni ederim.

Korhan Ayhan · 10 Kasım 2009

Selamlar,

Üstteki mesajımda kırmızı renkle belirttiğim bölüm sıralama işlemini yapmaktadır. Sıralamayı istediğiniz zaman yapmak istiyorsanız ayrı bir makro ile yapabilirsiniz. Yada alanı mouse ile seçip elle sıralama yapabilirsiniz.

abkbek · 11 Kasım 2009

Sayın Korhan Ayhan,
iyi günler diliyorum. son gönderdiğiniz düzeltmeyi de yaptım ancak şöyle bir sorun var. kayıtların karşılarında yazan değer kadar dağılımda yer almaları gerekirken dağılımı kontrol ettiğimde bazı kayıtların eksik yada fazla tekrar ettiğini farkettim. incelemeniz için ekte gönderiyorum son halini, kontrol adlı sayfayı incelerseniz anlatmak istediğimi daha anlayabilirsiniz.

abkbek · 11 Kasım 2009

Sayın Korhan Ayhan,
Sorun sanıyorum şu, son gönderdiğim örnek üzerinden anlatmaya çalışayım, toplam 246 ders görecek 110 kayıt bulunuyor, bunları otuzarlı gruplara dağıtırken öncelikle eksik ders ozetini dikkate almamız gerekiyor. 2 eksik dersi olanlar 93 kayıt (2*93=186) , 3 eksik dersi olanlar 8 kayıt (3*8=24) ve 4 eksik dersi olanlar 9 kayıt (4*9=36) bu durumda ;
186 (2 eksik dersi olanların tamamı)
16 (3 eksik dersi olanlardan - 8 kayıt buradan artacak)
+ 18 (4 eksik dersi olanlardan - 9 kayıt {2*9=18}buradan artacak)
220 lik grup ilk 8 derse sorunsuz ve eşit şekilde dağılabilir ancak bundan sonrası için sorun çıkıyor 9 ve 10ncu derslere yeter sayıda kayıt olmadığından dokuzuncu ders 8+9=17 kayıtlı ve onuncu ders 9 kayıtlı olmalı,
tabi böyle bir dağılımı (hem de her seferinde değişken olan kayıt ve ders sayısıyla) yapmak beni fazlasıyla aşıyor. eğer yapabilirseniz çok ama çok minnettar olurum. saygılar

abkbek · 13 Kasım 2009

Acaba önce tüm kayıtları tam turla bitirecek şekilde dağıtsak, yani yukarıdaki örnek için mesela tüm kayıtların en az 2 dersi eksik dolayısıyla tüm kayıtları ikişer defa dağıtsak, daha sonra kalanları ayrı bir sayfada listeleyip bunları dağıtsak olabilir mi?
(hergün bu sorunla yatıp kalkıyorum)

Korhan Ayhan · 13 Kasım 2009

Selamlar,

Örneğin KAYIT001 den 2 ders var, KAYIT002 den 3 adet var.

Burada amacımız dağılım yapılırken adet miktarları tamamen sıfırlamak mı?

abkbek · 13 Kasım 2009

Evet Sayın Korhan Ayhan

Korhan Ayhan · 13 Kasım 2009

Selamlar,

Aşağıdaki kod ile listenizi 9. DERS grubuna kadar dağıtabiliyorum. Fakat bu gruptan sonra kısır döngüye girdiği için makro sonlanmıyor. Bunun sebebide üretilen değerin kendinden önceki sütunlarda tekrarlanmaması şartıdır. Bu durumda en iyi kombinasyonu bulana kadar oluşan değerler tamamen silinip liste tekrar oluşturulmalıdır. En iyi kombinasyon ne zaman bulunur tabiki bunu bilmemiz mümkün değil. Bu aşamada farklı bir çözüm yolu aramak daha sağlıklı görünüyor.

Kod:

Option Explicit
 
Sub DERS_DAĞILIMI()
    Dim KAYIT_SATIR_SAYISI As Long, TOPLAM_DERS_SAYISI As Long
    Dim SAYAÇ As Byte, KONTROL As Integer, SATIR As Long, SÜTUN As Byte, YENİ_SATIR As Long, İLK_SÜTUN As Byte
    Dim DERSE_GİRECEK_MİKTAR As Integer, DERS_GRUP_SAYISI As Integer, DERS_GRUP_TEKRAR_SAYISI As Byte
    Dim ADRES1 As String, ADRES2 As String, X As Byte, ÜRETİLEN_SAYI As Long, WF As WorksheetFunction
    
    Set WF = WorksheetFunction
 
    KAYIT_SATIR_SAYISI = Range("A65536").End(3).Row
    TOPLAM_DERS_SAYISI = WF.Sum(Range("B:B"))
    
    Range("C:IV").Clear
    
    SATIR = Val(Application.InputBox("Listeniz hangi satırdan itibaren oluşturulsun?", , 1))
    If SATIR <= 0 Then Exit Sub
    
    SÜTUN = Val(Application.InputBox("Listeniz hangi sütundan itibaren oluşturulsun?", , 4))
    If SÜTUN <= 0 Then Exit Sub
 
    DERSE_GİRECEK_MİKTAR = Val(Application.InputBox("Derse girecek miktarı giriniz.", , 27))
    If DERSE_GİRECEK_MİKTAR <= 0 Then Exit Sub
 
    DERS_GRUP_SAYISI = Val(Application.InputBox("Ders grup sayısını giriniz.", , 0))
    If DERS_GRUP_SAYISI <= 0 Then Exit Sub
    
    DERS_GRUP_TEKRAR_SAYISI = Val(Application.InputBox("Ders kendinden önce kaç grupta tekrarlanmasın?", , 2))
    If DERS_GRUP_TEKRAR_SAYISI <= 0 Then Exit Sub
    
    If (DERSE_GİRECEK_MİKTAR * DERS_GRUP_SAYISI) < TOPLAM_DERS_SAYISI Then
        MsgBox "Girdiğiniz DERS GRUP SAYISI tüm kayıtları listelemek için uygun değildir." & Chr(10) & Chr(10) & _
        "Uygun grup sayısı : " & WF.RoundUp(TOPLAM_DERS_SAYISI / DERSE_GİRECEK_MİKTAR, 0) & Chr(10) & Chr(10) & _
        "İşleminiz iptal edilmiştir.", vbCritical, "Dikkat !"
        Exit Sub
    End If
    
    ADRES1 = Range(Cells(SATIR, SÜTUN), Cells(65536, SÜTUN + DERS_GRUP_SAYISI - 1)).Address
    ADRES2 = Range(Cells(SATIR + 1, SÜTUN), Cells(65536, SÜTUN + DERS_GRUP_SAYISI - 1)).Address
        
    For X = SÜTUN To SÜTUN + DERS_GRUP_SAYISI - 1
        SAYAÇ = SAYAÇ + 1
        Cells(SATIR, X) = SAYAÇ & ". Ders"
        Cells(SATIR, X).Font.Bold = True
    Next
    
    SATIR = SATIR + 1
    YENİ_SATIR = SATIR
    
    Randomize
 
BAŞLA:
    
    ÜRETİLEN_SAYI = Int((KAYIT_SATIR_SAYISI * Rnd) + 1)
    
    KONTROL = 0
 
    If ÜRETİLEN_SAYI > 1 Then
        If (YENİ_SATIR - SATIR + 2) > DERSE_GİRECEK_MİKTAR + 1 Then
            'SIRALAMA YAPMAK İÇİN
            'Range(Cells(SATIR, SÜTUN), Cells(DERSE_GİRECEK_MİKTAR, SÜTUN)).Sort Key1:=Cells(SATIR, SÜTUN), Order1:=xlAscending, Header:=xlGuess, _
            'OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortTextAsNumbers
            YENİ_SATIR = SATIR
            SÜTUN = SÜTUN + 1
        End If
        
        If SÜTUN < DERS_GRUP_TEKRAR_SAYISI Then
            İLK_SÜTUN = 1
            Else
            İLK_SÜTUN = SÜTUN - DERS_GRUP_TEKRAR_SAYISI
        End If
        
        For X = İLK_SÜTUN To SÜTUN
            If X > 1 Then KONTROL = KONTROL + WF.CountIf(Columns(X), Cells(ÜRETİLEN_SAYI, 1))
        Next
        
        If KONTROL > 0 Then GoTo BAŞLA
        
        Cells(YENİ_SATIR, SÜTUN) = Cells(ÜRETİLEN_SAYI, 1)
        
        If WF.CountIf(Range(ADRES1), Cells(ÜRETİLEN_SAYI, 1)) = Cells(ÜRETİLEN_SAYI, 2) Then
            Cells(YENİ_SATIR, SÜTUN).Interior.ColorIndex = 1
            Cells(YENİ_SATIR, SÜTUN).Font.ColorIndex = 2
        ElseIf WF.CountIf(Range(ADRES1), Cells(ÜRETİLEN_SAYI, 1)) > Cells(ÜRETİLEN_SAYI, 2) Then
            Cells(YENİ_SATIR, SÜTUN).ClearContents
            GoTo BAŞLA
        End If
        YENİ_SATIR = YENİ_SATIR + 1
    End If
 
    If WF.CountA(Range(ADRES2)) <> TOPLAM_DERS_SAYISI Then GoTo BAŞLA
 
    Set WF = Nothing
 
    Cells.EntireColumn.AutoFit
 
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

abkbek · 13 Kasım 2009

İyi geceler sayın Korhan Ayhan,
Acaba önce tüm kayıtları tam turla bitirecek şekilde dağıtsak, yani yukarıdaki örnek için mesela tüm kayıtların en az 2 dersi eksik dolayısıyla tüm kayıtları ikişer defa dağıtsak, daha sonra kalanları ayrı bir sayfada listeleyip bunları dağıtsak olabilir mi?
bu durumda tüm kayıtları önce en az dersi sayısı olan değer kadar (bunu inputbox ile yapabilirsiniz sanıyorum) örnek için bu değer 2, daha sonra ikiden büyük değeri olanları ayrı bir sayfaya listeleyebilirsek (örnek liste için 3 ve 4 dersi eksik olanların kalanları 3-2=1 ve 4-2=3 listelenecek) döngü önlenebilir mi acaba

abkbek · 15 Kasım 2009

Sayın Korhan Ayhan üstadım iyi akşamlar,
Hala ümidimi kesmedim..

abkbek · 17 Kasım 2009

Sayın Korhan Ayhan,
İyi akşamlar diliyorum. acaba bakabildiniz mi?

abkbek · 22 Kasım 2009

Sayın Korhan Ayhan acaba ümit yok mu...?

Listeyi bir sütundaki kritere göre rastgele dağıtmak

abkbek

Ekli dosyalar

Korhan Ayhan

Administrator

abkbek

Korhan Ayhan

Administrator

abkbek

abkbek

abkbek

Korhan Ayhan

Administrator

abkbek

Korhan Ayhan

Administrator

abkbek

Ekli dosyalar

abkbek

abkbek

Korhan Ayhan

Administrator

abkbek

Korhan Ayhan

Administrator

abkbek

abkbek

abkbek

abkbek