Tek Ölçüte Göre Çekiliş Yapmak

[Fath]

Merhaba,
Ekli dosyanın "Kişi Verileri" sayfasında adları, soyadları, ve kod harfleri yazılan kişileri, "Çekiliş Tablosu" sayfasının "E" sütununa yazdırmak istiyorum.
Kurallar:
1- "ÇT" E sütununa yazdırılacak ismin "KV" sayfasındaki kod harfi, "ÇT" nin C sütununa uygun olacak. Bir başka anlatımla, kişi dağıtımındaki temel ölçüt kod harfleri olacak.
2- İsimler gelişigüzel dağıtılacak.
3-Bir kişi tabloya birden fazla kez yazılmayacak.
Çözüme ulaşmaya çalışırken yapılması teklif edilebilecek her türlü öneriye açığım; dosyada çözüme yönelik değişiklikler yapmakta bir sakınca görmüyorum. Anlaşılmayan bir nokta olursa bilgi verebilirim. İlginiz için teşekkür ederim.
Ekleme: Kişi Verileri sayfasında bulunan kişi sayısı deneme için 30 adet girilmiştir; bu sayı 200' e kadar düşünülebilir. Dolayısıyla Çekiliş Tablosu sayfasında da her birine ikişer kişi girilebilecek 100 sıra oluşabilir.

 

[Ömer BARAN]

Merhaba.

Listenin sıralı olmasında sakınca olmadığına göre;
-- aşağıdaki formülü Çekiliş sayfası E2 hücresine yapıştırın,
-- formülü yapıştırdığınız E2 hücresini seçin ve bu hücre seçili durumdayken, F2 tuşuna basarak hücre içerisine girin,
-- CTRL ve SHIFT tuşları basılı durumda iken ENTER tuşuna basarak işlemi tamamlayın.
Böylece formül dizi formülüne dönüşür.
İşlemi doğru yaptıysanız formül kendiliğinden {....} gibi köşeli parantez arasına alınmış olur.
-- E2 hücresini listeniz boyunca aşağı doğru kopyalayın.

=KAYDIR('Kişi Verileri'!$B$1;KÜÇÜK(EĞER('Kişi Verileri'!$C$2:$C$31=C2;SATIR('Kişi Verileri'!$C$2:$C$31));EĞERSAY($C$2:C2;C2))-1;0)

 

[Fath]

Üstad,
Harikasınız! Elleriniz dert görmesin. Sihir seyrediyormuş gibi oldum bir an
Küçük bir ricam olacak sizden. Şöyle ki, bunu bir de kodla yapma imkanımız var mı acaba?

 

[Ömer BARAN]

Tersten (alttan üste doğru) sıralı liste için önceki cevabımda verdiğim formülün son bölümündeki EĞERSAY($C$2:C2;C2))-1
yerine EĞERSAY('Kişi Verileri'!$C$2:$C$31;C2)-EĞERSAY($C$2:C2;C2)+1)-1
yazıp formülü aynı şekilde uygulayın.

Kod için uygun olduğumda bakarım.
.

 

[Fath]

İkinci öneriniz için de sağolun Hocam. Kodlu çözümünüzü ayrıca bekleyeceğim. Teşekkür ederim tekrardan.

 

[Ömer BARAN]

Karışık liste için aşağıdaki işlemleri, sırasıyla yapın.
--Sayfaya bir adet düğme/şekil/metin kutusu ekleyin,
-- Alt taraftan Çekiliş sayfasının adına fareyle sağ tıklayıp KOD GÖRÜNTÜLEyi seçin,
-- Açılacak VBA ekranında sağ taraftaki BOŞ alana aşağıdaki kod blokunu yapıştırıp VBA ekranını kapatın,
-- Sayfaya eklediğiniz nesneye fareyle sağ tıklayıp MAKRO ATAyı seçin,
-- Açılacak küçük ekranda DAGITIM makrosunun adını seçerek işlemi onaylayın.
Artık eklediğiniz bu nesneye her tıkladığınızda dağıtım en baştan tekrar yapılır.

Sub DAGITIM()
Set kv = Sheets("Kişi Verileri"): Set ct = Sheets("Çekiliş Tablosu")
If ct.Cells(Rows.Count, 5).End(3).Row > 1 Then ct.Range("E2:E" & Rows.Count).ClearContents
Application.ScreenUpdating = False: Application.Calculation = xlCalculationManual
Columns("F:G").Insert Shift:=xlToRight
kvson = kv.Cells(Rows.Count, 2).End(3).Row: kv.Range("B2:C" & kvson).Copy ct.[F2]
For sat = 2 To kvson
10: VBA.Randomize
sayi = CInt(Int((kvson * VBA.Rnd()) + 2))
    If ct.Cells(sayi, "F") <> "" And ct.Cells(sat, 3) = ct.Cells(sayi, "G") Then
        ct.Cells(sat, 5) = ct.Cells(sayi, "F")
        ct.Range("F" & sayi & ":G" & sayi).Delete Shift:=xlUp
        kvson = kvson - 1
    ElseIf ct.Cells(Rows.Count, "F").End(3).Row = 2 And ct.Range("C" & kvson) = ct.[G2] Then
            ct.Cells(kvson, 5) = ct.[F2]: ct.Range("F2:G2").Delete Shift:=xlUp
    Else: GoTo 10
    End If
Next
Columns("F:G").Delete Shift:=xlToLeft
Application.ScreenUpdating = True: Application.Calculation = xlCalculationAutomatic
MsgBox "İşlem tamamlandı.", vbInformation, "..:: Ömer BARAN ::.."
End Sub

 

[Fath]

Merhaba Hocam,
Öncelikle emeğinize sağlık; sizi uğraştırdım.
Hoşgörünüzü umarak ulaştığım sonucu paylaşmak istiyorum:
*Run-Time Error 438 hatası alıyorum (Nesne bu özelliği veya yöntemi desteklemiyor)
*Bir liste üretiyor ama bunu "Çekiliş Tablosu" sayfasında C sütununa girdiğimiz kod harfine göre yapmıyor.
*Yazılan isimler f ve g sütununa; kod tekrar çalıştırılırsa ardışık sütunlara yazılıyor.
*İsimlerin karşısına dönüp bir de harf kodlarını yazıyor.
*Kodu kaç defa çalıştırırsanız çalıştırın hep aynı sırayı üretiyor.

Ek olarak: Çekiliş sırasında kod çalışırken dağıtımın ortalama süresini 45-60 saniye olarak ayarlama imkanımız var mıdır?

 

[Ömer BARAN]

Belge ekte.
Doğal olarak temel varsayım; iki sayfadaki C sütununda yer alan harflerin iki taraftada aynı adette olmaları.
Kaldı ki; isim tekrarı olmaması koşulunuz da var.

İşlem süresini sınırlamaktan bahsetmişsiniz; işlem süresi, veri yığınının büyüklüğüne bağlı olarak değişecektir.
Ekteki belge yenilendi. 01.11.2018 04:00
.

 

[Fath]

Merhaba,
Herhalde benim excelde bir sorun var. Aynı hatalar hiç değişmeden tekrar ediyor. Yarın başka bir bilgisayarda deneyip sonucu yazarım. Kıymetli zamanınızı sorunumun çözümüne ayırdığınız için teşekkür ederim.
Herkese hayırlı geceler dilerim.

 

[Ömer BARAN]

Daha önceki kod cevabımda küçük değişiklik yaptım ve eklediğim belgeyi de buna göre güncelledim.
Eklediğim belgeyi tekrar indiriniz. Yeni belge içerisinde yazdığım yeni açıklamaları okuyunuz.

Denemelerinizi sadece benim gönderdiğim belge ile yapın.

Sorunu sadece asıl belgenizde yaşarsanız;
-- örnek belgenizle gerçek belgenizin satır/sütun yapılarını,
-- veri türlerini (SAYI/METİN/TARİH gibi),
-- verilerin başında/sonunda BOŞLUK karakteri olup olmadığını,
-- veri başlangıç satır numaralarının aynı olup olmadığını,
-- verilerin örnek belgeyle aynı sütunlarda olup/olmadığını,
kontrol edin.

Sağlıcakla.

 

[Ömer BARAN]

Bundan önceki son mesajımı okuyunuz.

 

[Fath]

Teşekkür ederim sayın Hocam. Elleriniz dert görmesin. Gecenin bir yarısı uğraşmış olmanız gözümden kaçmadı. Saygı duydum Büyük İnsan...

 

[Ömer BARAN]

Estağfurullah, eyvallah.
Kolay gelsin.

 

[Fath]

...