1 Attachment(s)
Help Required : Random Sampling of Data
Hi Experts,
I got the attached random sampling code from one of the excel forum. I request your help in customizing the codes so that it be very useful to add it as an excel add-in and use irrespective of the data range. My knowledge to to the below changes is very limited. Any help on this is greatly appreciated.
- The code shall work for the entire selection range (currently only 5 columns).
- There shall be an option to select the column basis of which the sampling has to be work (currently based on column A). Preferably a user form which loads the headers from the first row of the selection and then the user choose the column header basis of which sampling has to be done.
- Options for the results to be copied in to a new worksheet/workbook/add the word "sample" in the column next to the the selection range.
Thanks in advance
Code:
Option Explicit
Sub ClearData()
[H6].ClearContents
Sheet3.UsedRange.Offset(1).ClearContents
End Sub
Sub RandSample()
Dim arOrig, x, Key, Key1, iSubset, arRes()
Dim i As Long, j As Long
Dim dicRnd As Object, dicSorted As Object, dicUnq As Object, dicRes As Object
iSubset = InputBox("Enter a sample size ", "Sample Size")
If Not IsNumeric(iSubset) Then
MsgBox "Oops! Please enter a valid sample size.", vbCritical, "Wrong Entry"
Exit Sub
End If
arOrig = Selection.Value
Set dicRnd = CreateObject("Scripting.Dictionary")
Set dicUnq = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(arOrig)
Do
x = Rnd
Loop Until Not dicRnd.Exists(x)
dicUnq(arOrig(i, 1)) = dicUnq.Count
dicRnd(x) = Join(Application.Index(arOrig, i, 0), "~")
Next
Set dicSorted = dictKeySortAscending(dicRnd)
For Each Key In dicRnd.Keys
dicSorted(Key) = dicRnd(Key)
Next
Set dicRes = CreateObject("Scripting.Dictionary")
For Each Key In dicUnq.Keys
i = 0
Do While i < iSubset
For Each Key1 In dicSorted.Keys
If CStr(Key) = Split(dicSorted(Key1), "~")(0) Then
dicRes(dicUnq(Key) & "," & i) = dicSorted(Key1)
dicSorted.Remove Key1
Exit For
End If
Next
i = i + 1
Loop
Next
ReDim arRes(dicRes.Count, 5)
i = 0
For Each Key In dicRes.Keys
x = Split(dicRes(Key), "~")
For j = 0 To 4
arRes(i, j) = x(j)
Next
i = i + 1
Next
Sheet3.Range("A2").Resize(dicRes.Count, 5) = arRes
MsgBox "Record Count: " & dicRes.Count & vbNewLine & "Unique Names: " & dicUnq.Count & vbNewLine & "Record/Name: " & iSubset
End Sub
Public Function dictKeySortAscending(dictList As Object) As Object
Dim curKey As Variant
Dim sortArray As Object
Dim i As Integer
Set sortArray = CreateObject("System.Collections.ArrayList")
If dictList.Count > 1 Then
With sortArray
For Each curKey In dictList.Keys
.Add curKey
Next curKey
.Sort
Set dictKeySortAscending = CreateObject("Scripting.Dictionary")
For i = 0 To .Count - 1
dictKeySortAscending.Add .Item(i), 1
Next
End With
Else
dictKeySortAscending = dictList
End If
Set sortArray = Nothing
End Function