DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
Altın Üyelik Hakkında Bilgi
1) 1. grup ve 2. grupta aynı sayılar yer alacak mı?Değerli forum yöneticileri ve forum üyeleri hepinize sunmuş olduğunuz kolaylıklardan dolayı sonsuz teşekkür ederim benim ufak bir yardıma ihtiyacım var aşağıdaki ekteki dosyada ( kura çekilişi yaparak numara atamak istiyorum ) sorunumu dile getirmeye çalıştım yapabileceğiniz yardımlar için şimdiden teşekkür ederim...
saygılarımla...
Option Explicit
Public Sub subCekilis()
'FGHIJKL-->> 6/7/8/9/10/11/12
Dim Csf As Excel.Worksheet: Set Csf = Worksheets("Hsr")
Dim rngGiris As Range, rngCikis As Range, rngBul As Range
Dim sut As Long, syc_i As Long, sat As Long, strAra$
'\\ Boş sütunu tespit edelim.
sut = 0
For syc_i = 6 To 12
If Cells(3, syc_i).Text = "" Then
sut = syc_i
Exit For
End If
Next syc_i
'\\ Boş sütunlar dolu ise çıkalım ve mesaj olarak verelim.
If sut = 0 Then
MsgBox "Haftalık çekiliş tamamlanmıştır!", vbCritical + vbOKOnly, "Hsayar"
GoTo subSon
End If
'\\ Çekiliş Sırasını belirleyelim.
islemKura:
With Csf
Select Case sut
Case Is = 6, 8, 10, 12
'Grup1
Set rngGiris = .Range(.Cells(3, 1), .Cells(14, 1))
Set rngCikis = .Range(.Cells(3, sut), .Cells(14, sut))
Call PrSubSütunlarıKarıştır(rngGiris, rngCikis)
'Grup2
Set rngGiris = .Range(.Cells(15, 1), .Cells(26, 1))
Set rngCikis = .Range(.Cells(15, sut), .Cells(26, sut))
Call PrSubSütunlarıKarıştır(rngGiris, rngCikis)
Case Is = 7, 9, 11
'Grup2
Set rngGiris = .Range(.Cells(15, 1), .Cells(26, 1))
Set rngCikis = .Range(.Cells(3, sut), .Cells(14, sut))
Call PrSubSütunlarıKarıştır(rngGiris, rngCikis)
'Grup1
Set rngGiris = .Range(.Cells(3, 1), .Cells(14, 1))
Set rngCikis = .Range(.Cells(15, sut), .Cells(26, sut))
Call PrSubSütunlarıKarıştır(rngGiris, rngCikis)
Case Else
End Select
End With
islemSatırKontrol:
If sut < 7 Then GoTo subSon
With Csf
For sat = 2 To 26
strAra = .Cells(sat, sut).Value
Set rngBul = .Range(.Cells(sat, 6), .Cells(sat, sut - 1))
Set rngBul = rngBul.Cells.Find(strAra, LookIn:=xlValues, LookAt:=xlWhole)
If (Not rngBul Is Nothing) Then
' MsgBox strAra & " değeri daha evvel girilmiştir.", 16, "Hsayar"
GoTo islemKura
End If
Next sat
End With
subSon:
Set Csf = Nothing
Set rngGiris = Nothing
Set rngCikis = Nothing
Set rngBul = Nothing
End Sub
Sub PrSubSütunlarıKarıştır(rngGiris As Range, rngCikis As Range)
Dim data As Variant
Dim snlTab() As Variant
Dim tabSnc() As Variant
Dim ii As Long, sat As Long
snlTab = rngGiris
'\\ Karıştırılacak verilerin index nolarını alıyoruz.
data = BenzersizRastgeleSayilar(UBound(snlTab), LBound(snlTab), UBound(snlTab), enCevapHayır)
If TypeName(data) = "Boolean" Then
MsgBox "BenzersizRastgeleSayilar fonksiyonu için verdiğiniz KacAdetSayi, EnKucukSayi, EnBuyukSayi değerlerinden bir veya daha fazlası uyumsuzdur."
Exit Sub
End If
'\\ Elemanları İndex numaralarından tabSnc Dizisine atıyoruz.
ii = 0
For sat = LBound(snlTab) To UBound(snlTab)
ii = ii + 1
ReDim Preserve tabSnc(1 To 1, 1 To ii)
tabSnc(1, ii) = snlTab(data(sat), 1)
Next sat
'\\ tabSnc Dizisini Çalışma sayfasına geri veriyoruz.
rngCikis = Empty
rngCikis = Application.Transpose(tabSnc)
'\\ Değişknelerimizi siliyoruz.
Erase snlTab, tabSnc, data
Set rngGiris = Nothing
Set rngCikis = Nothing
End Subonu ben yapamam, benim yaptığım değerleri karıştırmaktan ibaret.teşekkür ederim hazırlamış olduğunuz program için benim isteklerimin bayağı bi kısmını karşılamış zahmet verdim sizede yalnız sayıları çekerken mesela pazartesi için butana tek seferde basıp sayılar çekmek yerine butona her basışımızda bir sayı atamazmıyız...
Rica ederim.arkadaşım süpersin harikasın ne diyim alt alta aynı sayılar denk gelmiyor şimdi kaldı sayıları düğmeye tek tek basıp ataybilmek emeğine sağlık zahmet verdim size...
Art niyet gözetenlere kodları gösteriniz. Dikkatinizi çekti ise Cumartesi, pazar günleri çekilişleri aynı satırlar geldiği için uzun sürüyor.bunu izah ediniz.sizin yapmış olduğunuz düğmeye bir kere basıyoruz ve o günün çekilişini direk olarak atıyor ama çekilişi izleyecek olan üyelerin buna karşı bir art niyet gözetme durumları var ondan düğmeye bir kere basıp o günün çekilişini tek tek olarak atamak bu şekilde olursa eğer herhangibir sıkıntı olmaz...ondan dolayı umarım anlatabilmişimdir...
birde bu programa temizleme butonu ekleyemezmiyiz acaba...
Eğer varsa bile bunu ben yapamam dedim.evet haklısınız haftasonuna aynı satırlar denk gelmesin diye uzun sürüyor temizleme butonu eklediğiniz için teşekkür ederim aslında tüm bunlar için size sonsuz minnettarım...
art niyet gösterenlere kodları göstereceğimden kesinlikle emin olabilirsiniz...herhangibir günün çekilişini gerçekleştirmek için butona bir kez basıp rakamları tek tek atayabilme imkanımız varmı bunu siz yapamam mı dediniz yoksa böyle birşey olamaz mı dediniz anlayamadım eğer mümkünse bunu yapabilecek birisi varmıdır acaba forumda teşekkürler yinede tüm herşey için başınızı ağırttım...
denemek lazım, şimdiden bir şey söylemem müm kün değil.Ben birşey daha sormak istiyorum size bu çekiliş haftasının süresini uzatabilirmiyiz yani Pazartesi gününe ilk çekilen numaranın tekrar pazartesi ilk numara olma olasılığına kadar uzatabilirmiyiz bu programı...umarım anlatabilmişimdir teşekkürler...
sn dodopali sabhleyin biraz baktım ama internet bağlantısındaki kesiklikten dolayı ekleyemedim....umarım yapılabilir çalışmalarınızı dört gözle bekliyorum kolay gelsin iyi günler...