excel kura çekme

[hsanal31]

excel de iyi olan arkadaşlar ekte bulunan dosyamı inceleyip ,yapmak istediğimin excelde olup olamayacağı veya nasıl yapılacağı konusunda bilgilendirirse sevinirim.

 

[Orion1]

Dosyanız ekte.

Sub kura()
Dim sat As Long, i As Long, col As Collection
Dim indis As Long, k As Range
Set col = New Collection
Sheets("kura").Select
Randomize
For i = 2 To Cells(65536, "B").End(xlUp).Row
    col.Add (Cells(i, "B").Value)
Next i
sat = 2
With Sheets("yerlestir")
    .Range("B2:C65536").ClearContents
    Do While col.Count > 1
        indis = CInt(Int(Rnd() * col.Count - 1) + 2)
        .Cells(sat, "B").Value = col.Item(indis)
        Set k = Range("B2:B65536").Find(col.Item(indis), , xlValues, xlWhole)
        If Not k Is Nothing Then
            .Cells(sat, "C").Value = k.Offset(0, 1).Value
        End If
        sat = sat + 1
        col.Remove (indis)
    Loop
    .Cells(sat, "B").Value = col.Item(1)
    Set k = Range("B2:B65536").Find(col.Item(1), , xlValues, xlWhole)
    If Not k Is Nothing Then
        .Cells(sat, "C").Value = k.Offset(0, 1).Value
    End If

End With
MsgBox "Kura Çekimi Bitti", vbOKOnly + vbInformation, "KURA"
End Sub

 

[hsanal31]

teşekkür ederim tam istediğim gibi olmuş

 

[hsanal31]

eline sağlık

 

[Orion1]

Rica ederim.
İyi çalışmalar.

 

[istanbulcahan]

Dosyanız ekte.

Sub kura()
Dim sat As Long, i As Long, col As Collection
Dim indis As Long, k As Range
Set col = New Collection
Sheets("kura").Select
Randomize
For i = 2 To Cells(65536, "B").End(xlUp).Row
    col.Add (Cells(i, "B").Value)
Next i
sat = 2
With Sheets("yerlestir")
    .Range("B2:C65536").ClearContents
    Do While col.Count > 1
        indis = CInt(Int(Rnd() * col.Count - 1) + 2)
        .Cells(sat, "B").Value = col.Item(indis)
        Set k = Range("B2:B65536").Find(col.Item(indis), , xlValues, xlWhole)
        If Not k Is Nothing Then
            .Cells(sat, "C").Value = k.Offset(0, 1).Value
        End If
        sat = sat + 1
        col.Remove (indis)
    Loop
    .Cells(sat, "B").Value = col.Item(1)
    Set k = Range("B2:B65536").Find(col.Item(1), , xlValues, xlWhole)
    If Not k Is Nothing Then
        .Cells(sat, "C").Value = k.Offset(0, 1).Value
    End If

End With
MsgBox "Kura Çekimi Bitti", vbOKOnly + vbInformation, "KURA"
End Sub

Benimde işime yaradı, elinize sağlık.

 

[gokhanbek]

arkadaşlar cok hızlı kurra cekimi yapılıyor ve gitityor.
biraz yavaş sıra sıra kimin cıktığı gör gör çekilse dahada heyecanlı olur

 

[Muhammet Okumuş]

http://www.excel.web.tr/f48/kura-uygulamasy-t115637.html
Dosyayı inceleyiniz.

 

[semsev]

benim anlayamadığım bu siteye öğrencilerde geliyor yazık değil mi bilgiyi parayla satmak. belki alacak durumu yok. aç gözlüyüz aççç

 

[Astalavista58]

benim anlayamadığım bu siteye öğrencilerde geliyor yazık değil mi bilgiyi parayla satmak. belki alacak durumu yok. aç gözlüyüz aççç

Merhaba altın üyelik yıllık çok çok cüzi bir miktar, hatta o miktara tavuk dürüm bile kalmadı. Ayrıca formun amacı para olsaydı kayıt ücretli olurdu diye düşünüyorum.