1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:
27:
28:
29:
30:
31:
32:
33:
34:
35:
36:
37:
38:
39:
40:
41:
42:
43:
44:
45:
46:
47:
48:
49:
50:
51:
52:
53:
54:
55:
56:
57:
58:
59:
60:
61:
62:
63:
64:
65:
66:
67:
68:
69:
70:
71:
72:
73:
74:
75:
76:
77:
78:
79:
80:
81:
82:
83:
84:
85:
86:
87:
88:
89:
90:
91:
92:
93:
94:
95:
96:
97:
98:
99:
100:
101:
102:
103:
104:
105:
106:
|
Option Explicit
Const samplenum = 10
Private Sub CommandButton1_Click()
Randomize
SeedBox.Value = Int(Rnd * 1000000)
End Sub
Private Sub CommandButton2_Click()
Dim datasource As Worksheet
Set datasource = Worksheets("New")
Dim allData As Range
Set allData = datasource.Range(datasource.Cells(2, 2), datasource.Cells(2.2).End(xlDown))
Dim allUnique() As Variant
allUnique = UniqueValues(allData)
Dim SampleIDs() As Variant
ReDim SampleIDs(LBound(allUnique) To UBound(allUnique))
Dim i As Integer, m As Integer
i = LBound(allUnique): m = LBound(allUnique)
Dim uniqueID As Variant
For Each uniqueID In allUnique
If (Split(uniqueID, ",")(1) > 10) Then
SampleIDs(i) = Split(uniqueID, ",")(0)
m = m + 1
i = i + 1
End If
Next
If m < i Then ReDim Preserve SampleIDs(LBound(allUnique), m)
Rnd (SeedBox.Value)
Set allData = datasource.Range(datasource.Cells(1, 1), datasource.Cells(1.1).End(xlToRight).End(xlDown))
cases.Cells.Clear
datasource.Range(datasource.Cells(1, 1), datasource.Cells(1, 1).End(xlToRight)).Copy (cases.Cells(1, 1))
Dim samplerows As Integer
samplerows = 0
For Each uniqueID In SampleIDs
HWork.Cells.Clear
HWork.Cells(1, 1) = Worksheets("New").Cells(1, 2)
HWork.Cells(2, 1) = uniqueID
allData.AdvancedFilter xlFilterCopy, HWork.Range("A1:A2"), HWork.Range("B1"), False
Dim samples As Integer
samples = 0
While samples < samplenum
Dim rcount As Integer
rcount = HWork.UsedRange.Rows.Count
Dim randrow As Integer
randrow = Int((rcount - 2 + 1) * Rnd + 2)
HWork.Range(HWork.Cells(randrow, 2), HWork.Cells(randrow, 2).End(xlToRight)).Cut (cases.Cells(samplerows + 2, 1))
HWork.Rows(randrow).Delete
samples = samples + 1
samplerows = samplerows + 1
Wend
Next
HWork.Cells.Clear
cases.UsedRange.Columns.AutoFit
End Sub
Public Function UniqueValues(SourceValues As Variant) As Variant
'Returns a variant containing the unique values contained within SourceValues
'If called from a worksheet array formula, returns either a row or column array, as needed.
Dim Items As New Collection
Dim i As Long, j As Long, m As Long, nCols As Long, nRows As Long, Row As Long
Dim rg As Range
Dim cel As Variant, Result() As Variant
On Error Resume Next
Set rg = Application.Caller
For Each cel In SourceValues
If cel <> "" Then Items.Add CStr(cel), CStr(cel)
Next
If rg Is Nothing Then
Else
nCols = rg.Columns.Count
nRows = rg.Rows.Count
m = Application.Max(nCols, nRows)
End If
On Error GoTo 0
i = Items.Count
ReDim Result(1 To i)
For Row = 1 To i
j = 0
If rg Is Nothing Then
For Each cel In SourceValues
If cel = Items(Row) Then j = j + 1
Next
Result(Row) = Items(Row) & "," & j
Else
Result(Row) = Items(Row) & "," & Application.CountIf(SourceValues, Items(Row))
End If
Next Row
If m > i Then
ReDim Preserve Result(1 To m)
For Row = i + 1 To m
Result(Row) = ""
Next Row
End If
If nRows < 2 Then
UniqueValues = Result
Else
UniqueValues = Application.Transpose(Result)
End If
End Function
|
