Eşleştirme yardım

[leumruk]

Syn. muokumuş,
Çok sık yapmıyorsa böyle idare edin. Şu an aklıma bir çare gelmiyor. Son hücreye gelen çakışmalarda çözüm çok zor. Eğer isterseniz seçimi sıfırlamasını sağlayabilirim. O zaman da ikinci kurayı en baştan yeniden çekmeniz gerekir.

 

[Muhammet Okumuş]

tamam hocam teşekkür ederim ilginize.zahmet olmazsa onu yerleştirin.hani seçim tekrarlanıyor diye uyarı çıkıyordu.ona bi sınır koyabilir miyiz. 3 kez denesin aynı sonuç çıkarso işlemi durdursun

 

[leumruk]

Syn muokumuş,
İsimlerin tek tek gelmesi şart mı?
Kurayı bir anda çekse olmaz mı?
Eğer bir anda yaparsak, doğruyu bulana kadar döngü sağlayabiliriz.
Eğer olur dersen yarın kodları o şekilde değiştireyim.

 

[Muhammet Okumuş]

olur hocam neden olmasın.ben sadece heyecan olsun diye tek tek istedim

 

[hsayar]

sn muokumus ben yaptım ancak şöyle bir proplme var tablonuz her zaman tam olarak eşleşmiyor:
MURAT KAYA RECEP YILDIRIM
ELİF BOZ HALİT TAN
MEHMET POLAT TANSU PASO
AHMET KILINÇ FIRAT CANLI
FATMA ERDOĞAN SERKAN SEÇKİN
METE ARSLAN ERHAN ÇALIŞKAN
SALİH KARA AYŞE GÜNAY
#YOK #YOK

eşleştimesinde açıkta kalan
al berktaş - betül ateş ikiside aynı grupta bu durumda ne olacak.... o zaman kodları yenide çalıştıracaksınız.

 

[hsayar]

bunlarda kodlarınız bir module ekleyip deneyiniz;

Option Explicit
Sub öğrenci_eşleştir()
Dim Csf As Worksheet: Set Csf = ThisWorkbook.Worksheets("KURA")
Dim datGrp1() As Long, datGrp2() As Long
Dim tabGrp1() As Variant, tabGrp2() As Variant, tabSnc() As Variant
Dim i%, ii%, iii%  ', iStn%, iStr%, lngSnsNo1&, lngSnsNo0&, lngSnsNo2&
Dim sonStr%
With Csf
  tabGrp1 = .Range("a2:c9")
  tabGrp2 = .Range("e2:g9")

  For i = 1 To 200
    datGrp1 = UniqueRandomNumbers(1, 1, UBound(tabGrp1))
    datGrp2 = UniqueRandomNumbers(1, 1, UBound(tabGrp2))
    
    If tabGrp1(datGrp1(1), 1) <> Empty And tabGrp2(datGrp2(1), 1) <> Empty Then
      If tabGrp1(datGrp1(1), 2) <> tabGrp2(datGrp2(1), 2) And tabGrp1(datGrp1(1), 3) <> tabGrp2(datGrp2(1), 3) Then
        ii = ii + 1
        ReDim Preserve tabSnc(1 To 2, 1 To ii)
        tabSnc(1, ii) = tabGrp1(datGrp1(1), 1)
        tabSnc(2, ii) = tabGrp2(datGrp2(1), 1)
        For iii = 1 To 3
          tabGrp1(datGrp1(1), iii) = Empty
          tabGrp2(datGrp2(1), iii) = Empty
        Next iii
        If ii = 9 Then GoTo son
      End If
    End If
  Next i
son:
  Stop
  Range("j2:k9").Value = Application.Transpose(tabSnc)
End With
Erase tabGrp1(), tabGrp2()
Erase datGrp1(), datGrp2()

End Sub

Function UniqueRandomNumbers(KacAdetSayi As Long, EnKucukSayi As Long, EnBuyukSayi As Long) As Variant
'Benzersiz Rastgele Sayılar Üretir.
'Kullanımı Aşağıdaki gibidir
'Data = UniqueRandomNumbers(6, 1, 49)
Dim RandColl As Collection, varTemp() As Long
Dim k&, i&, j&
UniqueRandomNumbers = False

If KacAdetSayi < 1 Then Exit Function
If EnKucukSayi > EnBuyukSayi Then Exit Function
If KacAdetSayi > (EnBuyukSayi - EnKucukSayi + 1) Then Exit Function
Set RandColl = New Collection
Randomize
Do
On Error Resume Next
i = CLng(Rnd * (EnBuyukSayi - EnKucukSayi) + EnKucukSayi)
RandColl.Add i, CStr(i)
On Error GoTo 0
Loop Until RandColl.Count = KacAdetSayi

ReDim varTemp(1 To KacAdetSayi)

For i = 1 To KacAdetSayi
varTemp(i) = RandColl(i)
Next i
'**************ripek********************
For i = 1 To KacAdetSayi - 1
    For j = i + 1 To KacAdetSayi
        If varTemp(i) > varTemp(j) Then
            k = varTemp(i)
            varTemp(i) = varTemp(j)
            varTemp(j) = k
        End If
    Next j
Next i
'**************ripek********************
Set RandColl = Nothing
UniqueRandomNumbers = varTemp
Erase varTemp
k = 0: i = 0: j = 0
'*****www.excel.web.Tr***********
End Function

 

[Muhammet Okumuş]

hocam yapamadım.siz dosya ekleyip gönderebilirmisiniz?ben de hata verdi

 

[hsayar]

buyrun... işşinizi görer inşallah.

 

[Muhammet Okumuş]

hsayar hocam çok teşekkür ederim

 

[hsayar]

rica ederim..