' usulan dari siti / asal usul gak pake usil
'-------------------------------------------
Dim DatRange As Range
Dim Acak As Long
Dim N As Long, i As Long, p As Long
' menentukan range data
Set DatRange = Cells(1).CurrentRegion.Offset(1, 0)
Set DatRange = DatRange.Resize(DatRange.Rows.Count - 1, 1)
' menebak banyaknya data
N = DatRange.Rows.Count
' jika nilai z masih 0 (program baru dijalankan)
' dibuat salinan data "urutan data" ke array dCopy
If z = 0 Then
c = 0
For i = 1 To N
ReDim Preserve dCopy(1 To i)
dCopy(i) = i
Next
End If
'menentukan max Loop-Counter (p)
p = IIf(UBound(dCopy) >= 3, 3, UBound(dCopy))
For i = 1 To p
' membuat angka random rentangan:
' 1 s/d [banyaknya nomor yg belum 'dipakai']
Randomize
Acak = 1 + Int(Rnd * UBound(dCopy))
' memberi penanda pada data yg terpilih
Range("C1").Offset(dCopy(Acak), c).Value = "v"
' === [No Urutan] yg sudah dipakai dieliminasi ==
' array dCopy: elemen ke (acak) diganti isinya
' dengan elemen ter-akhir
dCopy(Acak) = dCopy(UBound(dCopy))
' membatasi eliminasi agar tidak terjadi error
' (lha wong array tinggal 1 elemen >> kok masih mau diperkecil)
If UBound(dCopy) > 1 Then
ReDim Preserve dCopy(1 To UBound(dCopy) - 1)
End If
' setiap terjadi penandaan "v"
' nilai z dinaikkan
z = z + 1
' jika z sudah melebihi N, z di reset ke 0
If z >= N Then z = 0
Next i
' agar penandaan ditulis di KOLOM (c) berikutnya
c = c + 1
If c > (N / 3) Then
c = 0
z = 0
End If
End Sub
Private Sub CommandButton1_Click()
' agar makro dapat dijalankan dgn [Tombwoll]
RandomLagi_RandomLagi
End Sub
Private Sub CommandButton2_Click()
' reset, kembali ke keadaan awal
z = 0
c = 0
Range("C2:M200").ClearContents
End Sub
mungkin bisa diganti (antara lalin) seperti ini
Public z As Long, c As Integer, dCopy()
Sub RandomLagi_RandomLagi()
' usulan dari siti / asal usul gak pake usil
'-------------------------------------------
Dim DatRng As Range
Dim Acak As Long, N As Long, i As Long, p As Long
Set DatRng = Sheet1.Cells(1).CurrentRegion.Offset(1, 0)
Set DatRng = DatRng.Resize(DatRng.Rows.Count - 1, 1)
N = DatRng.Rows.Count
If z = 0 Then
c = 0
Range("C2:M200").ClearContents
For i = 1 To N
ReDim Preserve dCopy(1 To i)
dCopy(i) = i
Next
End If
p = IIf(UBound(dCopy) >= 3, 3, UBound(dCopy))
For i = 1 To p
Randomize
Acak = 1 + Int(Rnd * UBound(dCopy))
Range("C1").Offset(dCopy(Acak), c).Value = "v"
dCopy(Acak) = dCopy(UBound(dCopy))
If UBound(dCopy) > 1 Then ReDim Preserve dCopy(1 To UBound(dCopy) - 1)
z = z + 1
If z >= N Then z = 0
Next i
c = c + 1
If c > (N / 3) Then z = 0
End Sub
2011/3/24 ..:: priel ::.. <XAVREIL@gmail.com>
>
>
> Rekans,
> kembali nubie mau nanya tentang macro
> kali ini, kasus yang saya hadapi adalah, saya ingin memilih sample secara acak dari sekumpulan data yang sudah tersusun. dalam contoh ini, jumlah datanya adalah 10, dan saya ingin mengambil 3 sample, secara acak
>
> Script macro yang baru saya pahami adalah sbb :
>
> Sub random_lagi()
> Dim acak, x
> 'Dicari jumlah data dikurangi headernya
> x = WorksheetFunction.CountA(range("A:A")) - 1
> [B1].Select
> For i = 1 To 3
> acak = Int((Rnd * x))
> ActiveCell.Offset(acak, 0).Value = "Pilih"
> Next i
> End Sub
>
> Data terletak di kolom A, dan data yang terpilih akan diberi label di sebelahnya dengan label "Pilih"
> berikut adalah datanya :
>
> Name
> Kaya
> Akiko
> Maiya
> Akemi
> Hana
> Kami
> Aneko
> Kaori
> Miya
> Tanabe
>
> Mohon maap banget nggak bisa kasih dalam bentuk Excel, internet nebeng kantor ndak bisa upload attachment (~___~)"
>
> Masalahnya :
> saya sudah coba script tersebut, setelah running beberapa kali, ada kalanya data yang sudah terpilih kembali terpilih. Padahal yang saya mau, data yang sudah terpilih tidak akan dipilih lagi
>
> Mohon petunjuknya
>
> salam
> -Priel-
>
| silakan klik... ada buku nih.... dijamin bukan "bom buku"... |
| http://goo.gl/iQauc... btw kalau ada kerjaan enak kabarin momods |
| http://www.facebook.com/group.php?gid=37671048001&ref=mf |
+-------------------------------------------------------------------+
| DILARANG : MLM, money game, OOT, iklan tanpa izin, SARA, testing, |
| pembicaraan pribadi, one line message, melecehkan, tidak sopan. |
+-------------------------------------------------------------------+
| Buat subjek yang kreatif, jangan : "tanya", "help", "mohon bantu" |
| Usahakan besar attachment < 200 kb. Gunakan winzip jika perlu. |
+-------------------------------------------------------------------+
| Ajak teman-teman Anda bergabung dengan mengirim e-mail kosong ke |
| XL-mania-subscribe@yahoogroups.com atau kirimkan mereka file dari |
| http://groups.yahoo.com/group/XL-mania/files/Promotion/ |
+-------------------------------------------------------------------+
| Berikan testimoni di : http://www.friendster.com/xlmania atau... |
| http://www.xl-mania.com/2008/06/testimoni-xl-mania.html |
+-------------------------------------------------------------------+
| Message lama ada di : |
| http://groups.yahoo.com/group/XL-mania/messages [perlu yahoo id] |
| http://www.mail-archive.com/xl-mania@yahoogroups.com |
+-------------------------------------------------------------------+
Nenhum comentário:
Postar um comentário