Sayıya göre şans

[ALTINYAYLA]

Arkadaşlar facebookta bir hemşehri grubum var. Grubun üyelerine yönelik bir kitap hediye kampanyası yapacağım.

Gruba üye ekleyen hemşehrilerimize eklediği üye sayısına göre kura şansı verecek bir kod ve düğme lazım. Alakanıza şimdiden teşekkür ederim.

  

 

[YUSUF44]

Aşağıdaki makroyu bir modüle kopyalayıp deneyiniz:

Sub kurasansi()
Set s1 = Sheets("Sayfa1")
Set s2 = Sheets("Sayfa2")
son1 = s1.Cells(Rows.Count, "A").End(3).Row
eski = s2.Cells(Rows.Count, "A").End(3).Row
If eski > 1 Then
    sor = MsgBox("Eski veriler silinsin mi?", vbYesNo)
    If sor = vbYes Then
        s2.Range("A1:B" & eski).ClearContents
        s2.[A1] = "Adı Soyadı"
        s2.[B1] = "Kura Sonucu"
        For kisi = 4 To son1
            say = s1.Cells(kisi, "B") - 1
            yeni = s2.Cells(Rows.Count, "A").End(3).Row + 1
            s2.Range("A" & yeni & ":A" & yeni + say) = s1.Cells(kisi, "A")
        Next
    End If
Else
    s2.[A1] = "Adı Soyadı"
    s2.[B1] = "Kura Sonucu"
    For kisi = 4 To son1
        say = s1.Cells(kisi, "B") - 1
        yeni = s2.Cells(Rows.Count, "A").End(3).Row + 1
        s2.Range("A" & yeni & ":A" & yeni + say) = s1.Cells(kisi, "A")
    Next
End If
son2 = s2.Cells(Rows.Count, "A").End(3).Row
10:
kazanan = WorksheetFunction.RandBetween(2, son2)
If s2.Cells(kazanan, "B") = "" Then
    s2.Cells(kazanan, "B") = "Kazandı"
    devam = MsgBox("Kazanan talihli : " & s2.Cells(kazanan, "A") & Chr(10) & Chr(10) & _
            "Devam edilsin mi?", vbYesNo)
    If devam = vbYes Then
        GoTo 10
    Else
        MsgBox "Kura çekimi tamamlandı, verilen hediye sayısı : " & _
            WorksheetFunction.CountA(s2.Range("B2:B" & son2))
        Exit Sub
    End If
Else
    GoTo 10
End If
End Sub

 

[ALTINYAYLA]

Nasıl kullanacağız ekledim de

 

[YUSUF44]

Kendiniz demiştiniz aslında "kod ve düğme lazım" diye. Kod budur. Kopyalayın, dosyanızda Alt+F11 yapın, Insert menüsünden Module seçin ve açılan sayfaya kodları yapıştırın. Dosyanıza geçin. Sayfaya bir düğme/resim/nesne ekleyin. Eklediğinize sağ tıklayıp "makro ata" deyin ve listeden kurasansi makrosunu seçip işlemi tamamlayın. Artık o eklediğinize her bastığınızda makro çalışacaktır.

 

[1Al2Ver]

Sayın Yusuf44 merhaba,

Çözümden ben de faydalandım, teşekkür ederim,

Olabiliyor ise kura şansını (örnekte, ilk kişi için ;4) C sütununa yazdırabilir miyiz ?

Gereken ilave kodu öğrenmek isterim,

Teşekkür ederim.

 

[YUSUF44]

Sayın Yusuf44 merhaba,

Çözümden ben de faydalandım, teşekkür ederim,

Olabiliyor ise kura şansını (örnekte, ilk kişi için ;4) C sütununa yazdırabilir miyiz ?

Gereken ilave kodu öğrenmek isterim,

Teşekkür ederim.

İsteğinizi anlamadım maalesef.

 

[1Al2Ver]

Sayın Yusuf44 tekrar merhaba,

2 nci sayfaya yazdırılan sonuçları fark etmemiştim,

Oradaki verileri kullanarak kendim hallederim,

İlginiz için teşekkür ederim.

 

[YUSUF44]

Belirtmeyi unutmuşum, kura sonuçları Sayfa2'de oluşturulmaktadır. Gerekirse bu sayfadaki kazananlar da ayrıca düzenlenebilir.