kura çekme

mutluedenercan · 11 Ağustos 2011

Peki Hocam,
ben deniyom biraz şu kodları verirmisinz

1 - başa bir satır ilave ettim (amacım ilk satıra bir gösterge yerlaştirip o anda tarananı büyük göstermesi idi olduda , ama ilk yerleştirmeleri 2. satırdan başlatamadım yani şube isimleri üzerine yerleştirme yapmaya başladı bir satır atla 2.satırdan yerleştir yapamıyorum.

2- beklemeyi yarım saniye yapabilirmiyim

teşekkür

zyrec · 11 Ağustos 2011

Necdet Yeşertener' Alıntı:
Aşağıdaki kodda koyu kırmızı olan değer şube sayısını ifade etmektedir.

Option Base 1
Sub Dagit()
Dim c As Range, _
i As Integer, _
j As Integer, _
Sube(8) As Integer, _
K_Kalan As Integer, _
E_Kalan As Integer, _
Kalan As Integer, _
Satir As Integer

K_Kalan = Cells(Rows.Count, "B").End(3).Row - 1
E_Kalan = Cells(Rows.Count, "A").End(3).Row - 1
If E_Kalan > K_Kalan Then
Kalan = E_Kalan
Else
Kalan = K_Kalan
End If

Range("C2:J" & E_Kalan).ClearContents

For i = 1 To 3
Sube(i) = 1
Next i

j = 0
For i = Kalan To 0 Step -1
j = j + 1
If j > 3 Then j = 1
If E_Kalan > 0 Then
Randomize
Satir = Int((E_Kalan * Rnd) + 1) + 1
Range("A" & Satir).Activate
Range("A" & Satir).Interior.ColorIndex = 3
Application.Wait (Now + TimeValue("0:00:01"))
Range("A" & Satir).Interior.ColorIndex = 5
Application.Wait (Now + TimeValue("0:00:01"))

Sube(j) = Sube(j) + 1
Cells(Sube(j), j + 2) = Cells(Satir, "A")
Range("A" & Satir).Delete Shift:=xlUp
E_Kalan = E_Kalan - 1
End If

If K_Kalan > 0 Then
Randomize
Satir = Int((K_Kalan * Rnd) + 1) + 1
Range("B" & Satir).Activate
Range("B" & Satir).Interior.ColorIndex = 3
Application.Wait (Now + TimeValue("0:00:01"))
Range("B" & Satir).Interior.ColorIndex = 5
Application.Wait (Now + TimeValue("0:00:01"))

Sube(j) = Sube(j) + 1
Cells(Sube(j), j + 2) = Cells(Satir, "B")
Range("B" & Satir).Delete Shift:=xlUp
K_Kalan = K_Kalan - 1
End If

Next i

MsgBox "Dağıtım Tamamlanmıştır....", vbInformation, "N. YEŞERTENER --> www.excel.web.tr"

End Sub

Çok teşekkür ederim ilginiz için.

mutluedenercan · 12 Ağustos 2011

Peki Hocam,
şu kodları verirmisinz

1 - başa bir satır ilave ettim (amacım ilk satıra bir gösterge yerlaştirip o anda tarananı büyük göstermesi idi olduda , ama ilk yerleştirmeleri 2. satırdan başlatamadım yani şube isimleri üzerine yerleştirme yapmaya başladı bir satır atla 2.satırdan yerleştir yapamıyorum.

2- beklemeyi yarım saniye yapabilirmiyim

teşekkür

Necdet · 12 Ağustos 2011

Merhaba,

Aşağıdaki kodları dener misiniz? Kodlar "Kura" sayfasının kod bölümünde olmalı.

Not : bekletme kodları Sayın Levent Menteşoğlu'ndan alınmıştır.
Çekiliş Makrosu, 7 Nolu mesaj

Kod:

Private Sub CommandButton1_Click()
 
    Dim Sınıf_Adet  As Integer, _
        E_Kalan     As Integer, _
        K_Kalan     As Integer, _
        Kalan       As Integer, _
        Satir       As Integer, _
        Renk        As Integer, _
        a           As Integer, _
        b           As Integer, _
        i           As Integer, _
        j           As Integer, _
        k           As Integer, _
        Sat         As Integer, _
        Sube()      As Integer, _
        Syf()       As String, _
        Sayfa       As Worksheet
 
    Sınıf_Adet = 8
    Application.ScreenUpdating = False
 
    i = Sheets.Count - 1
    If i > 1 Then
        ReDim Syf(1 To i)
        For Each Sayfa In Worksheets
            If Not Sayfa.Name = "Kura" Then
                j = j + 1
                Syf(j) = Sayfa.Name
            End If
        Next Sayfa
        Application.DisplayAlerts = False
        Sheets(Syf).Delete
    End If
 
    ReDim Syf(1 To Sınıf_Adet)
    For i = 1 To Sınıf_Adet
        Sheets.Add After:=Worksheets(Worksheets.Count)
        ActiveSheet.Name = i & "A"
        ActiveSheet.Range("A1") = "Öğrenci Adı ve Soyadı"
        ActiveSheet.Columns("A:A").EntireColumn.AutoFit
    Next i
 
    Sheets("Kura").Select
    Application.ScreenUpdating = True
    ActiveSheet.Shapes("Ok").Visible = True
 
    K_Kalan = Cells(Rows.Count, "A").End(3).Row - 1
    E_Kalan = Cells(Rows.Count, "B").End(3).Row - 1
    If E_Kalan > K_Kalan Then
        Kalan = E_Kalan
    Else
        Kalan = K_Kalan
    End If
 
    ReDim Sube(1 To Sınıf_Adet)
 
    For i = 1 To Sınıf_Adet
        Sube(i) = 1
    Next i
 
    j = 0
    For i = Kalan To 0 Step -1
 
        j = j + 1
        If j > Sınıf_Adet Then j = 1
 
        k = j * 2 + 2
        With ActiveSheet.Shapes("Ok")
            .Top = Cells(10, k).Offset(3, 0).Top + 5
            .Left = Cells(10, k).Offset(3, 0).Left + 5
        End With
 
        If K_Kalan > 0 Then
 
            For a = 1 To 30
                For b = 1 To 8000
                    DoEvents
                Next
                Randomize
                Renk = Int(56 * Rnd) + 1
                Randomize
                Satir = Int((E_Kalan * Rnd) + 1) + 1
                With Range("H2")
                    .Value = Cells(Satir, "A")
                    .Font.ColorIndex = Renk
                End With
             Next
 
            Sube(j) = Sube(j) + 1
            Sheets(j & "A").Cells(Sube(j), "A") = Range("H2")
            Range("A" & Satir).Delete Shift:=xlUp
            K_Kalan = K_Kalan - 1
        End If
 
        If E_Kalan > 0 Then
 
            For a = 1 To 60
                For b = 1 To 4000
                    DoEvents
                Next
                Randomize
                Renk = Int(56 * Rnd) + 1
                Satir = Int((E_Kalan * Rnd) + 1) + 1
                With Range("H6")
                    .Value = Cells(Satir, "B")
                    .Font.ColorIndex = Renk
                End With
            Next
 
            Sube(j) = Sube(j) + 1
            Sheets(j & "A").Cells(Sube(j), "A") = Range("H6")
            Range("B" & Satir).Delete Shift:=xlUp
            E_Kalan = E_Kalan - 1
        End If
 
        Range("H2:R4,H6:R8").ClearContents
    Next i
    MsgBox "DAĞITIM TAMAMLANMIŞTIR....", vbInformation, "N. YEŞERTENER --> [URL="http://www.excel.web.tr/"]www.excel.web.tr[/URL]"
 
    ActiveSheet.Shapes("Ok").Visible = False
 
End Sub

mutluedenercan · 15 Ağustos 2011

kodları dediğiniz gibi aldım
dağit düğmesine basınca
dağıt makrosu bulunamadı dedi

Necdet · 15 Ağustos 2011

o zaman dosyayı alın

mutluedenercan · 16 Ağustos 2011

dosyayı aldım da XLSM uzantılı.. bende açmıyor

exel olarak gönderseniz

Necdet · 16 Ağustos 2011

Merhaba,

24 Nolu mesajda 2003 sürümü ile dosya eklenmiştir.

mutluedenercan · 16 Ağustos 2011

Teşekkürler

aldım

çalışıyor

Necdet · 16 Ağustos 2011

Güle güle kullanınız.

mutluedenercan · 16 Ağustos 2011

Hocam ,
1 - 1A 2A...sınıfların adlarını değiştirdim...tarama sonucunda 1A 2A...sayfalırını açıyor
yani ekrandaki sınıf isimlerine göre taradığını atmıyor kendi sayfa adı veriyor
ben 1A 1B 1C diye isim koydum o 1A 2A 3A sayfaları açtı

2 - sıfı gösteren ok varya o hangi kodla oluyor

teşekkür

Necdet · 17 Ağustos 2011

Merhaba,

Son gayretimle birşeyler yaptım, umarım işinize yarar.

Yine aşağıdaki kodlar "Kura" sayfasının kod bölümünde olacak.

Kod:

Private Sub CommandButton1_Click()
    
    Dim Sınıf_Adet  As Integer, _
        E_Kalan     As Integer, _
        K_Kalan     As Integer, _
        Kalan       As Integer, _
        Satir       As Integer, _
        Renk        As Integer, _
        a           As Integer, _
        b           As Integer, _
        i           As Integer, _
        j           As Integer, _
        k           As Integer, _
        Sat         As Integer, _
        Sube()      As Integer, _
        Sinif       As String, _
        Syf()       As String, _
        Sayfa       As Worksheet
                    
    Sınıf_Adet = Range("P16")
    
    Application.ScreenUpdating = False
    
    i = Sheets.Count - 1
    If i > 1 Then
        ReDim Syf(1 To i)
        For Each Sayfa In Worksheets
            If Not Sayfa.Name = "Kura" Then
                j = j + 1
                Syf(j) = Sayfa.Name
            End If
        Next Sayfa
        Application.DisplayAlerts = False
        Sheets(Syf).Delete
    End If
    
    ReDim Syf(1 To Sınıf_Adet)
    For i = 1 To Sınıf_Adet
        Sheets.Add After:=Worksheets(Worksheets.Count)
        ActiveSheet.Name = Sheets("Kura").Cells(2, i + 5)
        ActiveSheet.Range("A1") = "ÖĞRENCİ ADI VE SOYADI"
    
        ActiveSheet.Rows("1:1").RowHeight = 24
        ActiveSheet.Columns("A:A").ColumnWidth = 36
        With ActiveSheet.Columns("A:A")
            .ColumnWidth = 36
            .HorizontalAlignment = xlLeft
            .VerticalAlignment = xlCenter
            .WrapText = False
            .Orientation = 0
            .AddIndent = False
            .IndentLevel = 1
            .ShrinkToFit = False
            .ReadingOrder = xlContext
            .MergeCells = False
        End With
    
    Next i
    
    Sheets("Kura").Select
    Application.ScreenUpdating = True
    ActiveSheet.Shapes("Ok").Visible = True
    
    K_Kalan = Cells(Rows.Count, "A").End(3).Row - 2
    E_Kalan = Cells(Rows.Count, "B").End(3).Row - 2
    If E_Kalan > K_Kalan Then
        Kalan = E_Kalan
    Else
        Kalan = K_Kalan
    End If
    
    ReDim Sube(1 To Sınıf_Adet)
    
    For i = 1 To Sınıf_Adet
        Sube(i) = 1
    Next i
   
    j = 0
    For i = Kalan To 0 Step -1
    
        j = j + 1
        If j > Sınıf_Adet Then j = 1
        Sinif = Cells(2, j + 5)
        
        k = j + 5
        With ActiveSheet.Shapes("Ok")
            .Top = Cells(2, k).Offset(1, 0).Top + 2
            .Left = Cells(2, k).Offset(1, 0).Left + 3
        End With
                
        If K_Kalan > 0 Then
            
            For a = 1 To 30
                For b = 1 To 8000
                    DoEvents
                Next
                Randomize
                Renk = Int(56 * Rnd) + 1
                Randomize
                Satir = Int((K_Kalan * Rnd) + 1) + 2
                With Range("F15")
                    .Value = Cells(Satir, "A")
                    .Font.ColorIndex = Renk
                End With
             Next
                
            Sube(j) = Sube(j) + 1
            Sheets(Sinif).Cells(Sube(j), "A") = Range("F15")
            Range("A" & Satir).Delete Shift:=xlUp
            K_Kalan = K_Kalan - 1
        End If
        
        If E_Kalan > 0 Then
            
            For a = 1 To 60
                For b = 1 To 4000
                    DoEvents
                Next
                Randomize
                Renk = Int(56 * Rnd) + 1
                Satir = Int((E_Kalan * Rnd) + 1) + 2
                With Range("F19")
                    .Value = Cells(Satir, "B")
                    .Font.ColorIndex = Renk
                End With
            Next
            
            Sube(j) = Sube(j) + 1
            Sheets(Sinif).Cells(Sube(j), "A") = Range("F19")
            Range("B" & Satir).Delete Shift:=xlUp
            E_Kalan = E_Kalan - 1
        End If
        
        Range("F15:N17,F19:N21").ClearContents
    Next i
    MsgBox "DAĞITIM TAMAMLANMIŞTIR....", vbInformation, "N. YEŞERTENER --> [URL="http://www.excel.web.tr/"]www.excel.web.tr[/URL]"
    
    ActiveSheet.Shapes("Ok").Visible = False
    
End Sub

Kod:

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    On Error Resume Next
    If Intersect(Target, [2:2]) Is Nothing Then Exit Sub
    If Target.Column < 6 Then Exit Sub
    If Target.Value = "" Then Exit Sub
    Sheets(Target.Value).Select
    
End Sub

Kod:

Private Sub Worksheet_Change(ByVal Target As Range)
    If Intersect(Target, [P16]) Is Nothing Then Exit Sub
    If Target.Value = "" Or Target.Value = 0 Then Exit Sub
    
    Dim i   As Integer, _
        Harfler
        
    Harfler = Array(" ", "A", "B", "C", "D", "E", "F", "G", "H", "I", _
                    "J", "K", "L", "M", "N", "O", "P", "R", "S", _
                    "T", "U", "V", "Y", "Z", "AA", "AB", "AC", "AD")
    
    Application.ScreenUpdating = False
    i = 100
    
    With Range(Cells(2, "F"), Cells(2, i))
        .ClearContents
        .Borders(xlDiagonalDown).LineStyle = xlNone
        .Borders(xlDiagonalUp).LineStyle = xlNone
        .Borders(xlEdgeLeft).LineStyle = xlNone
        .Borders(xlEdgeTop).LineStyle = xlNone
        .Borders(xlEdgeBottom).LineStyle = xlNone
        .Borders(xlEdgeRight).LineStyle = xlNone
        .Borders(xlInsideVertical).LineStyle = xlNone
        .Borders(xlInsideHorizontal).LineStyle = xlNone
    End With
    i = 5 + Target.Value
    
    With Range(Cells(2, "F"), Cells(2, i))
        With .Borders(xlEdgeLeft)
            .LineStyle = xlDouble
            .Weight = xlThick
            .ColorIndex = 3
        End With
        With .Borders(xlEdgeTop)
            .LineStyle = xlDouble
            .Weight = xlThick
            .ColorIndex = 3
        End With
        With .Borders(xlEdgeBottom)
            .LineStyle = xlDouble
            .Weight = xlThick
            .ColorIndex = 3
        End With
        With .Borders(xlEdgeRight)
            .LineStyle = xlDouble
            .Weight = xlThick
            .ColorIndex = 3
        End With
        If Target.Value > 1 Then
            With .Borders(xlInsideVertical)
                .LineStyle = xlDouble
                .Weight = xlThick
                .ColorIndex = 3
            End With
        End If
    End With
    For i = 1 To Target.Value
        Cells(2, i + 5) = Range("P15") & " " & Harfler(i)
    Next i
End Sub

mutluedenercan · 17 Ağustos 2011

çok güzel elinize sağlık

şu ok geziyor ya seçilen sınıf o nu yapan kodlar hangileri

teşekkür

Necdet · 17 Ağustos 2011

mutluedenercan' Alıntı:
çok güzel elinize sağlık

şu ok geziyor ya seçilen sınıf o nu yapan kodlar hangileri

teşekkür

Ok şeklini gezdiren komut :

Kod:

        k = j + 5
        With ActiveSheet.Shapes("Ok")
            .Top = Cells(2, k).Offset(1, 0).Top + 2
            .Left = Cells(2, k).Offset(1, 0).Left + 3
        End With

mutluedenercan · 18 Ağustos 2011

iyide bu okun içindeki isim nereden degişiyo
şeklini nerden aldı
With ActiveSheet.Shapes("Ok")
.Top = Cells(2, k).Offset(1, 0).Top + 2
.Left = Cells(2, k).Offset(1, 0).Left + 3
anlamları ne

Necdet · 18 Ağustos 2011

mutluedenercan' Alıntı:
iyide bu okun içindeki isim nereden degişiyo
şeklini nerden aldı
With ActiveSheet.Shapes("Ok")
.Top = Cells(2, k).Offset(1, 0).Top + 2
.Left = Cells(2, k).Offset(1, 0).Left + 3
anlamları ne

tüm kodları tek tek açıklamak sanırım kolay değil.

orada gördüğünüz ok basit bir şekil
içine yazı yazabilirsiniz, bunu da siz araştırınız, hazıra konmayınız.

o şeklin adını "OK" olarak belirledim

biraz gavurcanız varsa top nedir left nedir anlarsınız.

şeklin seçilen hücreye göre yerleşimini sağlıyoruz.

genel olarak durum budur.

kadillak · 27 Ağustos 2011

sayı üretten kura çekimi yapamıyorum

Merhaba,
doktora tezim için hocalarım excelde sayı üretme komutuyla öğrenciler arasından kura çekimi yapmamı istediler. üç farklı grup var. birinci grup 23 kişi bunların arasından 9 kişi seçilecek. ikinci grup 27 kişi bunların arasından 12 kişi seçilecek, üçüncü grupta da 23 kişiden 9 kişi seçilecek. Bunu yapmak için öğrencilerin adlarını alfabetik olarak sıralayıp sonra rastgele sayılar üretilip kura çekileceğini, daha sonra sayıların büyükten küçüğe sıralanarak en büyükten başlayarak ne kadar kişi lazımsa seçileceğini söylediler. hocam öğrenci adlarını yazmadan numara vererek yaptı. S_SAYI_ÜRET komutuyla 100 e kadar sayılar rastgele vermiş. ama ben pek çok kez denedim ve yapamadım.
öğrenci isimlerini göndersem ve hocanın sadece sayılarla yaptığı dosyayı da göndersem isimlerle bunu yapabilecek bana yardımcı olabilecek biri var mıdır?

hocanın dosyası ekte, yardım edebilirseniz öğrenci adlarını da göndereyim. teşekkür ederim.

kaplancem · 12 Haziran 2012

merhaba;
benimde kura çekme ile ilgil ibir sorum olacak. turnuvalarda kullanmak amacı ile oluştururlan torbalardaki kişilerin rastgele gruplara dağıtılmasını ve aynı torbalarda bulunan kişilerin aynı gruba düşememesi gerekmektedir. ör 1 .torbadaki kişi sayısı kadar grup oluşmalı ve 1. torbadaki herkes farklı grupta olmalı. katımcı sayısına göre oluşturulan diğer torbalardaki kişilerde(yine aynı torbadakiler aynı gruba düşmeyecek şekilde)oluşturulan bu gruplara dağıtılmalı. işleyişin daha hızlı olması içinde bir çalıştırma butonu olmalı.
Yardımlarınızı bekliyor ve şimdiden teşekkür ediyorum.

mutluedenercan · 4 Eylül 2013

For a = 1 To 50
For b = 1 To 10000
DoEvents

burada a döngüsü karışımı gösterme

b seçim hızı deyilmi.....

peki restgele seçerken, satır bulma kodunda a ve b degişkeni yok nasıl bu a ve b kodları bu seçimi ve hızını etkiliyor...

merak ettim

mutluedenercan · 29 Eylül 2013

sayın Necdet Hocam,

programı geliştirmek ve değiştirmek istiyorum ,, buradanmı dile getireyim...yeni bir başlıkmı açayım

(sizin bu programı ekleyip yeni ihtiyaçları belirtmeme izin varmı, yoksa buradanmı bilirteyim...)

Okul addına teşekkür..........

kura çekme

mutluedenercan

zyrec

mutluedenercan

Necdet

Moderatör

Ekli dosyalar

mutluedenercan

Necdet

Moderatör

mutluedenercan

Necdet

Moderatör

mutluedenercan

Necdet

Moderatör

mutluedenercan

Necdet

Moderatör

Ekli dosyalar

mutluedenercan

Necdet

Moderatör

mutluedenercan

Necdet

Moderatör

kadillak

Ekli dosyalar

kaplancem

mutluedenercan

mutluedenercan