% ile rastgele tekrarsız seçim

[_frost_]

Herkese iyi günler. Ekteki dosyada A1 hücresinde sistem tarafındana atanmış kimlik numaraları var. Yapmak istediğim şey boş bir çalışma kitabına buton ekleyerek A1 deki dolu hücrelerin %10 luk kısmını veya seçime göre %20 lik kısmını yanındaki sütunlarla birlikte sayfa 2 ye kopyalaması. Random formulu kullanarak bir yere kadar geldim ama random formulu tekrarlar veridği için aynı isimler geliyor ve de işime tam yaramıyor. Dolu hücreler dedim çünkü bu bazen 100 satır bazen 300 satır. Birde seçim butonu yapabilirsem çok işe yarayacak. Örnek olarak "seçilmesi istenen % =10 , 20 , 30" gibi. Yüzde manuel girildiğinde a1 deki hücrelerin dolu olanlarına yinelemeden random sayı atanacak ve karşılık gelenleri bulunduğu satırı tamamen kopyalayıp sayfa 2 ye yapıştıracak. Umarım ablatabilmişimdir. Çok uğraştım forum sağolsun bir yere kadar gelebildim ama bir türlü beceremdim.

 

[leumruk]

Merhaba,
Makro isterseniz çözüm üretebilirim. Eğer karar verirseniz a sütununda tekrar eden numara olup olmadığını cevabınıza ekleyiniz.

 

[_frost_]

Makro veya formül her tülü yardıma muhtacım şu an. A1 sütunundaki numaralar şu anda birbirinden farkli ve tekrar eden yok. Sizin makro önerinize açığım. Saygılar selamlar...

 

[leumruk]

Merhaba,
Sayfanın sağındaki butona basmanız yeterli...

Sub Yuzdeli()
Set s2 = Sheets("Sayfa2")
s2.Cells.Delete
Tpl = [a65536].End(3).Row - 1
Sor = Application.InputBox("Lütfen yüzde oranını girin.", "YÜZDELİK DİLİM")
If Sor = False Then Exit Sub
If Sor > 100 Then Exit Sub
If Not IsNumeric(Sor) Then Exit Sub
oran = Round(Tpl * Sor / 100, 0)
Application.ScreenUpdating = False
Do
Tekrar:
sayi = Int((Tpl * Rnd) + 1)
Knt = WorksheetFunction.CountIf(s2.Range("a1:a" & s2.[a65536].End(3).Row), Cells(sayi + 1, "a"))
If Knt > 0 Then GoTo Tekrar
Range("a" & sayi + 1 & ":q" & sayi + 1).Copy s2.Cells(s2.[a65536].End(3).Row + 1, "a")
Say = Say + 1
Loop While oran <> Say
Application.CutCopyMode = False
MsgBox "İşlem tamamlanmıştır.", vbInformation, "l e u m r u k"
End Sub

 

[_frost_]

Efendim size ne kadar teşekkür etsem az. Çok işime yarayacak. Size de işlerinizde kolaylıklar diliyorum.

 

[_frost_]

sütun sayısı artarsa?

Benim size bir kaç sorum daha olacak müsadenizle. İlk sorum şu; sayfadaki sütun sayısı artınca makrodaki kod yeni sütunları görmüyor. Göndermiş olduğunuz dosyaya örnek olarak 2 sütun ekledim ve dosyayı ekte bulmanız mümkün. İkinci sorum, sizi tekrar aynı soruyla meşgul etmemek için, eğer sütun sayısı ilerde değişirse yapmam gereken nedir? Formülde ne tür değişiklikler yapmam gerekir?


Sub Yuzdeli()
Set s2 = Sheets("Sayfa2")
s2.Cells.Delete
Tpl = [a65536].End(3).Row - 1
Sor = Application.InputBox("Lütfen yüzde oranını girin.", "YÜZDELİK DİLİM")
If Sor = False Then Exit Sub
If Sor > 100 Then Exit Sub
If Not IsNumeric(Sor) Then Exit Sub
oran = Round(Tpl * Sor / 100, 0)
Application.ScreenUpdating = False
Do
Tekrar:
sayi = Int((Tpl * Rnd) + 1)
Knt = WorksheetFunction.CountIf(s2.Range("a1:a" & s2.[a65536].End(3).Row), Cells(sayi + 1, "a"))
If Knt > 0 Then GoTo Tekrar
Range("a" & sayi + 1 & ":q" & sayi + 1).Copy s2.Cells(s2.[a65536].End(3).Row + 1, "a")
Say = Say + 1
Loop While oran <> Say
Application.CutCopyMode = False
MsgBox "İşlem tamamlanmıştır.", vbInformation, "l e u m r u k"
End Sub

Kırmızıyla gösterilen yerlerin anlamı nedir acaba? Neden End(3) yazdık ama (4)değil mesela.. Ve neden ":q" ama "q" değil?

Şimdiden çok teşekkürler..

 

[leumruk]

Merhaba,
Kodlardaki "q" harfi tablonuzun son sütununu temsil ediyor. tablonuz hangi sütunda sona eriyorsa koddaki "q" lar yerine o sütunu yazacaksınız. Ekinize göre "S" yazmanız gerekiyor.
End(3).row ifadesi Son dolu satır numarasını verir. "a"nın sonuna getirdiğimiz için a sütununun son dolu satırına göre işlem yapar. Yani satır sayınız arttığında kod bunu otomatik algılar.

 

[_frost_]

End(3).row gibi sütun sayısına göre de bir kod yazmamız mümkün mü acaba? Sütun sayısı arttıkça, kod otomatik olarak sütun sayısını da artıracak. Sizin ilginize minnettarım.

 

[_frost_]

ayni kodlari ekteki dosyada denedigim zaman %10 unun uzerine cikinca hata veriyor daha dogrusu donuyor.
Range("a" & sayi + 1 & ":q" & sayi + 1).Copy s2.Cells(s2.[a65536].End(3).Row + 1, "a") q sutununu IV olarak degistirmistim ama degistirmeden de ayni sonucla karsilasiyorum.
Mumkunse hata nerde belirtebilirmisiniz..
not:Klavye ve isletim sistemi ingilizce oldugu icin Turkce karakterleri yazamiyorum.

 

[leumruk]

ayni kodlari ekteki dosyada denedigim zaman %10 unun uzerine cikinca hata veriyor daha dogrusu donuyor.
Range("a" & sayi + 1 & ":q" & sayi + 1).Copy s2.Cells(s2.[a65536].End(3).Row + 1, "a") q sutununu IV olarak degistirmistim ama degistirmeden de ayni sonucla karsilasiyorum.
Mumkunse hata nerde belirtebilirmisiniz..
not:Klavye ve isletim sistemi ingilizce oldugu icin Turkce karakterleri yazamiyorum.

Örnek dosyanız sanırım hatalı olan dosya değil, bu nedenle dosya üzerinde deneyemedim. Denemeden hata hakkında yorum yapamayacağım. Bir önceki mesajdaki isteğiniz yapılabilir; ama öncelikli olarak bu bahsettiğiniz hatayı çözmekte fayda var. Çözüm için hata mesajı veren dosyanın bir örneği gerekli.

 

[_frost_]

Efendim iyi akşamlar. Bana gelen dosyanın orjinalini göndermenin daha iyi olacağına inandığım için dosyayı ekledim. Aynı işlemi bu ve bunun gibi değişik dosyalara da yapmam gerekiyor. Ama bu dosyada çalışmıyor daha doğrusu bu aciz kardeşiniz beceremiyor..

 

[leumruk]

Merhaba,
Bu dosyanın hangi sütunundaki verilere göre işlem yapacak? Hangi sayfaya aktarma yapacak. Bunları da açıklar mısınız?

 

[_frost_]

efendim B sütunundaki bazı numaralar aynı ama bunlar % verilerek tekrarsız rastgele seçilip, hücrenin bulunduğu satırın tamamı ikinci bir sayfaya aktarılacak. Daha önceki yaptığınız gibi %10,%15 yada %20 gibi.. Bunlar elle manuel girilecek. Çok teşekkür ediyorum..

 

[leumruk]

Merhaba,
Verdiğiniz bilgide değişiklik olduğu için kod mantığını değiştirdim. Ayrıca enson dolu sütuna göre işlem yapacak şekilde düzenledim.

Sub Yuzdeli()
Set s2 = Sheets("Sayfa2")
s2.Cells.Delete
Tpl = [b65536].End(3).Row - 3
Sor = Application.InputBox("Lütfen yüzde oranını girin.", "YÜZDELİK DİLİM")
If Sor = False Then Exit Sub
If Sor > 100 Then Exit Sub
If Not IsNumeric(Sor) Then Exit Sub
oran = Round(Tpl * Sor / 100, 0)
Application.ScreenUpdating = False
Do
Tekrar:
sayi = Int((Tpl * Rnd) + 1)
Knt = WorksheetFunction.CountIf(s2.Range("a1:a" & s2.[a65536].End(3).Row), sayi + 3)
If Knt > 0 Then GoTo Tekrar
s2.Cells(s2.[a65536].End(3).Row + 1, "a") = sayi + 3
SonSut = Cells(3, 256).End(1).Column
Range(Cells(sayi + 3, 2), Cells(sayi + 3, SonSut)).Copy s2.Cells(s2.[b65536].End(3).Row + 1, "b")
Say = Say + 1
Loop While oran <> Say
s2.Columns(1).Delete Shift:=xlToLeft
Application.CutCopyMode = False
MsgBox "İşlem tamamlanmıştır.", vbInformation, "l e u m r u k"
End Sub

 

[Muhammet Okumuş]

sn leumruk
Application.CutCopyMode = False
başka bir dosya da ise nothing diye bir kod vardı.
Bu kodların anlamını açıklayabilir misiniz?

 

[leumruk]

sn leumruk
Application.CutCopyMode = False
başka bir dosya da ise nothing diye bir kod vardı.
Bu kodların anlamını açıklayabilir misiniz?

Application.CutCopyMode = False

Kopyalanan verinin hafızadan silinmesini sağlar. Nothing tek başına bir anlam ifade etmez. Daha çok o da hafızadaki verinin boşaltılmasında kullanılır.

 

[Muhammet Okumuş]

Sn leumruk teşekkür ederim. Acaba bu tarz sorulara cevap verebilecek bir kaynak ya da link var mı? Yazmış olduğunuz kodların bir kısmını anlayabiliyorum. Bir de yazmış olduğunuz kodda Application.ScreenUpdating = False ifadesi var. Ekrana yazma demek olan bu kodun sonunda Application.ScreenUpdating = True ifadesinin gelmesi gerekmiyor mu?

 

[leumruk]

sn muokumus,
Ben herhangi bir kaynak kullanmadığım için önereceğim bir kaynak yok. Bu forum bana yeterli geliyor. Ama bu faydalı kaynaklar olmadığı anlamına gelmez.
Diğer sorunuz: Böyle bir zorunluluk yok. Eğer kodun bir kısmında işlemin görünmemesini bir kısmında da görünmesini istiyorsanız yazmanız gerekir.

 

[Muhammet Okumuş]

Cevabınız için teşekkür ederim.

 

[leumruk]

Cevabınız için teşekkür ederim.

Rica ederim.