sütundan rastgele tekrarsız veri seçme

[gulkerpicci]

merhaba arkadaşlar,
makroya yeni başladım. iki tane sütunum var birinden sayılar diğerinde isimler , her ismin karşılığındaki rakamlardan 6 satır seçmek istiyorum toplamda 19 isim var bişeyler yaptım ama bu sadece tek bir kişi için oluyor.

yardımlarınız için teşekkürler şimdiden

Sub kelime()
[c1:c5].ClearContents
Randomize
For x = 1 To 6
Tekrar:
sayi = Int(([a65536].End(3).Row * Rnd) + 1)
If [c1] = "" Then tur = Cells(sayi, "b")
If WorksheetFunction.CountIf(Range("b1:b" & [b65536].End(3).Row), Cells(sayi, "b")) < 6 Then GoTo Tekrar
If WorksheetFunction.CountIf(Range("c1:c6"), Cells(sayi, "a")) > 0 Or Cells(sayi, "b") <> tur Then GoTo Tekrar
Cells(x, "c") = Cells(sayi, "a")
Next
MsgBox "Kişiler rastgele seçildi"
End Sub

 

[halit3]

Tam olarak sorunuzu anlayamadım ama bu kod A sutünundaki verileri B sutünuna isnenildiği kadar aktarıyor.

Sub rasgele()

Dim i As Long, sayi As Long, say As Long, sut As Long, son As Long
sayi = Cells(Rows.Count, "a").End(3).Row

sut = 1
son = sayi

sayi = Application.InputBox("Sayı giriniz.", "Maksinum sayı", sayi, 400, 30, , Type:=1)
If sayi = False Then
MsgBox "İşlemi iptal ettiniz"
Exit Sub
End If


If sayi > son Then sayi = son
ReDim deg1(son)
Range(Cells(1, sut + 1), Cells(Rows.Count, sut + 1)).ClearContents

Randomize Timer
For i = 1 To sayi
atla:
say = Int((Rnd * son) + 1)
If Val(deg1(say)) = 0 Then
'Cells(i, sut).Value = say
Cells(i, sut + 1).Value = Cells(say, sut).Value

deg1(say) = 1
Else
GoTo atla
End If

Next i


End Sub

 

[gulkerpicci]

Tam olarak sorunuzu anlayamadım ama bu kod A sutünundaki verileri B sutünuna isnenildiği kadar aktarıyor.

Sub rasgele()

Dim i As Long, sayi As Long, say As Long, sut As Long, son As Long
sayi = Cells(Rows.Count, "a").End(3).Row

sut = 1
son = sayi

sayi = Application.InputBox("Sayı giriniz.", "Maksinum sayı", sayi, 400, 30, , Type:=1)
If sayi = False Then
MsgBox "İşlemi iptal ettiniz"
Exit Sub
End If


If sayi > son Then sayi = son
ReDim deg1(son)
Range(Cells(1, sut + 1), Cells(Rows.Count, sut + 1)).ClearContents

Randomize Timer
For i = 1 To sayi
atla:
say = Int((Rnd * son) + 1)
If Val(deg1(say)) = 0 Then
'Cells(i, sut).Value = say
Cells(i, sut + 1).Value = Cells(say, sut).Value

deg1(say) = 1
Else
GoTo atla
End If

Next i


End Sub

merhabalar öncelikle cevap verdiğiniz için çok teşekkür ederim anlatabilmek adına dosya ekledim. her kişiden rassal 6 işlem seçmek istiyorum ama o kişini işlemleri birbirinden de farklı olsun istiyorum yardımcı olabilirseniz çokk sevinirim.

 

[halit3]

Bu kodu bir dene

Sub benzersiz()

Dim son2
Range("E2:K5000").ClearContents
'On Error Resume Next
son2 = Cells(Rows.Count, "B").End(xlUp).Row
Range("B1:B" & son2).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("E1"), Unique:=True

Dim i As Long, sayi As Long, say As Long, sut As Long, son As Long
sayi = Cells(Rows.Count, "b").End(3).Row
sut = 2
son = sayi
For j = 2 To Cells(Rows.Count, "e").End(3).Row
aranan1 = Cells(j, "e").Value
sayma = 0
If sayi > son Then sayi = son
ReDim deg1(son)
Randomize Timer
For i = 1 To 6
atla:
say = Int((Rnd * son) + 1)
If Val(deg1(say)) = 0 And Cells(say, sut).Value = aranan1 Then
sayma = sayma + 1
Cells(j, sut + 3 + sayma).Value = Cells(say, sut - 1).Value
deg1(say) = 1
Else
GoTo atla
End If
Next i

Next j
End Sub

 

[halit3]

Bu kod da farklı

Sub benzersiz2()


Dim i As Long, son As Long, say As Long, sut As Long
Dim r As Long, j As Long, say2 As Long, aranan1 As String

Range("E2:K5000").ClearContents

sut = 2
son = Cells(Rows.Count, sut).End(3).Row

ReDim deg2(5000)

say2 = 1
For r = 2 To son
aranan1 = Cells(r, sut).Value
If Cells(r, sut).Value <> "" Then
If WorksheetFunction.CountIf(Range("b2:b" & r), aranan1) = 1 Then
say2 = say2 + 1
deg2(say2) = aranan1
End If
End If
Next r


For j = 2 To say2
aranan1 = deg2(j)

Cells(j, sut + 3).Value = deg2(j)

sayma = 0

ReDim deg1(son)
Randomize Timer
For i = 1 To 6
atla:
say = Int((Rnd * son) + 1)
If Val(deg1(say)) = 0 And Cells(say, sut).Value = aranan1 Then
sayma = sayma + 1
Cells(j, sut + 3 + sayma).Value = Cells(say, sut - 1).Value
deg1(say) = 1
Else
GoTo atla
End If
Next i

Next j

MsgBox "işlem tamam"
End Sub

 

[halit3]

Bu kod da birazcık farklı
kırmızı ve mavi yerleri silebilirsiniz

Sub benzersiz3()


ZBasla = TimeValue(Now)
zaman = Timer

Range("D2:K5000").ClearContents
say1 = Cells(Rows.Count, "b").End(3).Row
sut = 2

ReDim ara1(say1): ReDim ara2(say1)

For j = 2 To say1
ara1(j) = Cells(j, "b")
ara2(j) = 1
Next j

say4 = 1

For r = 2 To say1
aranan1 = ara1(r)
[COLOR="blue"]sut6 = 0[/COLOR]
If ara2(r) = 1 Then
For i = r To say1
If ara1(i) = aranan1 Then
[COLOR="blue"]sut6 = sut6 + 1[/COLOR]
ara2(i) = 0
End If
Next i
say4 = say4 + 1
[COLOR="Red"]Cells(say4, sut + 2).Value = sut6[/COLOR] [COLOR="Blue"] & " Adet"[/COLOR]
Cells(say4, sut + 3).Value = aranan1

End If
Next r




For j = 2 To say4
aranan1 = Cells(j, "e").Value
say3 = 0
ReDim deg1(say1)
Randomize Timer
For i = 1 To 6
atla:
say2 = Int((Rnd * say1) + 1)
If Val(deg1(say2)) = 0 And Cells(say2, sut).Value = aranan1 Then
say3 = say3 + 1
Cells(j, sut + 3 + say3).Value = Cells(say2, sut - 1).Value [COLOR="Blue"]& " (" & say2 & ")"[/COLOR]
deg1(say2) = 1
Else
GoTo atla
End If
Next i
Next j

zBitis = TimeValue(Now)

MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & _
"İşlem süresi ; " & Format(Timer - zaman, "0.00") & Chr(10) & _
"Geçen Süre " & CDate(zBitis - ZBasla), vbInformation, " Sonuç Penceresi"



End Sub

 

[gulkerpicci]

Bu kod da farklı

Sub benzersiz2()


Dim i As Long, son As Long, say As Long, sut As Long
Dim r As Long, j As Long, say2 As Long, aranan1 As String

Range("E2:K5000").ClearContents

sut = 2
son = Cells(Rows.Count, sut).End(3).Row

ReDim deg2(5000)

say2 = 1
For r = 2 To son
aranan1 = Cells(r, sut).Value
If Cells(r, sut).Value <> "" Then
If WorksheetFunction.CountIf(Range("b2:b" & r), aranan1) = 1 Then
say2 = say2 + 1
deg2(say2) = aranan1
End If
End If
Next r


For j = 2 To say2
aranan1 = deg2(j)

Cells(j, sut + 3).Value = deg2(j)

sayma = 0

ReDim deg1(son)
Randomize Timer
For i = 1 To 6
atla:
say = Int((Rnd * son) + 1)
If Val(deg1(say)) = 0 And Cells(say, sut).Value = aranan1 Then
sayma = sayma + 1
Cells(j, sut + 3 + sayma).Value = Cells(say, sut - 1).Value
deg1(say) = 1
Else
GoTo atla
End If
Next i

Next j

MsgBox "işlem tamam"
End Sub

bu kodlar işime çok yaradı çok teşekkürler yardımınız için iyi günler dilerim size...

 

[halit3]

Önceki kodlarda kişilerde 6 seçenekten eksik olduğu zaman kodlar kilitleniyordu
Bu kod ile o da aşıldı kırmızı ve mavi yerleri kendiniz isterseniz silin

Private Sub CommandButton2_Click()


ZBasla = TimeValue(Now)
zaman = Timer

Range("D2:K5000").ClearContents
say1 = Cells(Rows.Count, "b").End(3).Row
sut = 2
son = 6

ReDim ara1(say1): ReDim ara2(say1): ReDim ara3(say1): ReDim ara4(say1): ReDim ara5(say1)

For j = 2 To say1
ara1(j) = Cells(j, "b")
ara2(j) = 1
Next j

say4 = 1

For r = 2 To say1
aranan1 = ara1(r)
sut6 = 0
If ara2(r) = 1 Then
For i = r To say1
If ara1(i) = ara1(r) Then
sut6 = sut6 + 1
ara2(i) = 0
End If
Next i
say4 = say4 + 1

[COLOR="Red"]ara4(say4) = sut6[/COLOR] [COLOR="blue"]& " Adet"[/COLOR]
ara3(say4) = ara1(r)
ara5(say4) = sut6
End If
Next r


For j = 2 To say4
'aranan2 = Cells(j, "e").Value
aranan2 = ara3(j)

Cells(j, "e").Value = ara3(j)
[COLOR="Red"]Cells(j, "d").Value = ara4(j)[/COLOR]

say3 = 0
ReDim deg1(say1)
Randomize Timer


For i = 1 To son

If Val(ara5(j)) < i Then GoTo atla2

atla:
say2 = Int((Rnd * say1) + 1)
If Val(deg1(say2)) = 0 And Cells(say2, sut).Value = aranan2 Then
say3 = say3 + 1
Cells(j, sut + 3 + say3).Value = Cells(say2, sut - 1).Value [COLOR="Blue"]& " (" & say2 & ")"[/COLOR]
deg1(say2) = 1
Else
GoTo atla
End If
Next i
atla2:
Next j

zBitis = TimeValue(Now)

MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & _
"İşlem süresi ; " & Format(Timer - zaman, "0.00") & Chr(10) & _
"Geçen Süre " & CDate(zBitis - ZBasla), vbInformation, " Sonuç Penceresi"



End Sub

 

[gulkerpicci]

yardımlarınız için çok teşekkürler Halit Bey