Kriterlere Uygun Yerleştirme

[peleryn]

Herkese Merhabalar;

Exceli çok seviyorum ve bu siteyi bulduğumdan beri excelle yapılabileceklerin büyüsü beni her geçen gün biraz daha sarıyor.Çok kısa zamanda benim için çok zor problemleri çözmeme yardımcı olan ve bu zevki yaşatan herkese çok teşekkür ediyorum.

Çözülen her dosyam peki şu da yapılabilir mi diye bir soru takıyor aklıma..
Ekteki dosyadada bu sorulardan biri var.
Bir isim ve bu isme ait kriterler seçiyorum (şu günler şu saatlerde seansa gelecek diye ) daha sonra bir buton yardımıyla bu ismin seçtiğim kriterlere uygun olarak seans tabloma dağılmasını istiyorum.

Örnek bir dosya hazırladım ama böylesi bir işlemi nasıl yaptırabileceğim konusunda hiçbir fikrim yok.

İlgilenecek olanlara şimdiden teşekkür ediyorum.

 

[peleryn]

yardımcı olanı bütün kandillerde hatırlayıp dua edicem valla bak

 

[peleryn]

Dosyayla bir ilgilenen çıkacağını umuyorum.Mutlaka birilerinin ne yapılabileceği konusunda bir fikri vardır.bu haftasonu halledebilirsem hafta içi inanılmaz işime yarayacak.ilgilerinizi bekliyorum herkese sevgiler.

 

[Orion1]

Dosyanız ektedir.

Sub yerlestir()
Dim i As Byte, sut As Range, j As Byte, z As Byte, say As Byte
Dim yerlesen As Byte
Sheets("TEŞEKKÜRLER").Select
Application.ScreenUpdating = False
For i = 5 To Cells(65536, "B").End(xlUp).Row
    For j = 4 To 6 Step 2
        Set sut = Range("L4:IV4").Find(Cells(i, j).Value, , xlValues, xlWhole)
        If Not sut Is Nothing Then
        say = 0
            yerlesen = 0
            For z = 5 To 35
                If Cells(z, "K").Value = Cells(i, j - 1).Value And _
                Not Cells(z, sut.Column) <> Empty Then
                    Cells(z, sut.Column).Value = Cells(i, "B").Value
                    say = say + 1
                    yerlesen = yerlesen + 1
                    If say = Cells(i, "G").Value Then Exit For
                End If
            Next z
        End If
    Next j
    Cells(i, "H").Value = yerlesen
Next i
Application.ScreenUpdating = True
MsgBox "Yerleşim tamamlandı.", vbOKOnly + vbInformation, "YERLEŞİM"

                    
End Sub

 

[peleryn]

Evren hocam sorumu yanıtsız bırakmayacağınızı biliyordum dosyanızı görünce çok mutlu oldum teşekkür ederim.tam istediğim gibi işliyor ancak halletmemiz gereken bir problem var:isimleri yerleştirirken tabloya en çok KAÇ TANE sütununda belirttiğim kadar isim yerleştirmesi gerekiyor.Ama anladığım kadarıyla belirtilen kriterleri 2 ye ayırıyor 1.gün ve seans a kaçtane kadar ve 2gün ve seansa da kaçtanede belirtilen kadar koyuyor.

Ben kendim halledebilir miyim diye kodları inceledim ama işin içinden çıkamadım.
Kısaca problemi netleşmesi açısından bir daha özetliyorum:
tabloya dağıtılacak isimler kriterler ne olursa olsun en çok KAÇTANE sütununda belirtilen sayı kadar olabilir.

İlginiz emeğiniz için tekrar teşekkürler.

 

[peleryn]

If say = Cells(i, "G").Value Then Exit For satırını

If say = Cells(i, "G").Value / 2 Then Exit For

olarak değiştirdim ve sorunumu hallettim hocam.Emeğinize sağlık çok teşekkür ediyorum.

Dua konusunda da sözüm söz

 

[peleryn]

Malesef halledememişim değeri 2 ye böldüğüm için tek sayı seçince yani KAÇTANE alanına 1,3,5,7 vs yazınca yine yanlış dağıtım yapıyor.Zaten şüpheliydim bu kadar da kolay olmamalıydı

 

[Orion1]

Her seans için istenen sayı kadar olacak şekilde düzenledim.
4ncü mesajda dosyayı güncelledim.
Deneyebilirsiniz.

 

[peleryn]

Evren Bey;

dosyayı denedim teşekkür ediyorum.şu seansların sayısı konusunda netleşip çözebilirsek benim için ideal bir dosya olacak.

ali-Salı-5.Seans-Cuma-2.Seans-6 şu anlama geliyor:

Salı 5. ve Cuma 2.Seanslara ali ismini dağıt ama 6 şar tane değil toplam 6 tane dağıt ve mümkünse eşit dağıt

yani KAÇTANE sütununda 6 sayısı varsa bunun mümkünse Salı 5.seansa 3 tane Cuma 2. seansa 3 tane ali yazarak hallolması gerekiyor.Bu şekilde dağıtmak için yeterli boş hücre yoksa yerleşen kısmında kaç tane yerleştirebildiğini görebilirim ve kalanlar için kendi çözümümü üretirim.

Umarım şu aşamada bu değişimi yapmak sizin için zor olmayacaktır.Heyecanla çözümünüzü bekliyorum.

 

[Orion1]

Zaten şu anda ali toplam 6 tane dağıtılıyor.
Siz buna ek olarak eşit dağılmasınımı istiyorsunuz?
O zaman dağıtılacak sütununa 7 tane yazarsanız nasıl eşit dağıtılacak.O zaman ne yapılacak.Onu söylememişsiniz.Şimdi ben yazıcam göndericem kodları bu sefer hoppallaaaaaa,haydi ben böyle istemiyordum.fazlası olanı ikinci seansa yazılsın az olanı ilk seansa yazılsın diyebilirsiniz.O zaman ne yapacaz.Tekrardan gerimi dönecez.Onun için lütfen yeterli açıklamaları yapınız.Ben belki bilmiyorsunuzdur bu gibi sorulara 1 den fazla yanıt vermiyorum.Biz burada soruyu yanıtlarken nasıl gerekli ihtimamı gösteriyorsak soruyu soran kişilerde o ihtimamı göstermelidir diye düşünüyorum.Yoksa bu kod yazma olayını bitiremeyiz!

 

[peleryn]

Hocam ekteki dosyada butona basarsanız demek istediğimi anlayacaksınız.Bahsettiğiniz şeylerin farkındayım ve sizleri fazladan yormamak için elimden gelen özeni gösteriyorum emin olabilirsiniz.Mesajların başından beri söylediğimden daha farklı birşey değil düzeltme olarak istediğim.Sonuç olarak her bir sütuna değil toplam tabloya 6 tane dağıtmaya çalışacak bunu yaparken de sütunlara eşit dağıtmaya çalışacak yani örneğinizdeki gibi sayı 7 ise bir sütunda 3 bir sütunda 4 taneyi tercih edecek bir sütuna 5 diğerine 2 gibi yapmayacak.
Ama eğer genel prensibiniz dosyalara 1 den fazla kere bakmamaksa sizi prensiplerinizle benim ısrarlı isteklerim arasında sıkıntıda bırakmak istemem.Dosyayla daha fazla ilgilenmek istemiyorsanız saygı duyarım.
Bugüne kadarki tüm emekleriniz bende saklı hepsi için size daima teşekkür borçluyum,teşekkürler.

 

[Orion1]

Neyse konu anlaşıldı.
Dosyayı istediğiniz gibi düzenledim.
Dosyanız ektedir..cool:

Sub yerlestir()
Dim i As Byte, sut As Range, j As Byte, z As Byte
Dim ilk_yerles As Integer, son_yerles As Integer
Dim yerlesen As Byte, sayi As Single
Sheets("TEŞEKKÜRLER").Select
Application.ScreenUpdating = False
For i = 5 To Cells(65536, "B").End(xlUp).Row
    yerlesen = 0
    sayi = Cells(i, "G").Value / 2
    ilk_yerles = WorksheetFunction.RoundDown(sayi, 0)
    son_yerles = Cells(i, "G").Value - ilk_yerles
    yerlesen = ilk_yerles
    For j = 4 To 6 Step 2
        say = 0
        If yerlesen > 0 Then
            Set sut = Range("L4:IV4").Find(Cells(i, j).Value, , xlValues, xlWhole)
            If Not sut Is Nothing Then
                For z = 5 To 35
                    If Cells(z, "K").Value = Cells(i, j - 1).Value And _
                    Not Cells(z, sut.Column) <> Empty Then
                        Cells(z, sut.Column).Value = Cells(i, "B").Value
                        say = say + 1
                        If say = yerlesen Then Exit For
                    End If
                Next z
            End If
        End If
        yerlesen = son_yerles
    Next j
    Cells(i, "H").Value = yerlesen
Next i
Application.ScreenUpdating = True
End Sub

 

[peleryn]

Evren hocam tek kelimeyle harika olmuş.Bundan sonra sorularım olduğunda çok daha özenilmiş açık ve anlaşılır olacak sabrınız,emeğiniz ve bu güzel dosya için çok teşekkür ederim.

 

[Orion1]

Evren hocam tek kelimeyle harika olmuş.Bundan sonra sorularım olduğunda çok daha özenilmiş açık ve anlaşılır olacak sabrınız,emeğiniz ve bu güzel dosya için çok teşekkür ederim.

Rica ederim.
İyi çalışmalar.