Random Sample

[Aman Semwal]

Hi,

Please guide vba to get random data with two condition first is the number of audit needed and second is the reason you want==

 

[Hui]

Aman

Firstly, Welcome to the Chandoo.org Forums

can you please post a small sample of data?

 

[Aman Semwal]

Sure

 

[Marc L]

Hi !

Please guide vba to get random data with two condition first is the number of audit needed and second is the reason you want==

Unclear …
​

 

[Chihiro]

It is unclear from your post and file what the second condition is.

Typically speaking, easiest way to take random sample is to...
Pair each item with random number (RAND()). Then sort based on RAND value and pick top x.

Depending on sampling, you may want to consider weighted sampling, top 5% etc.

 

[Chihiro]

FYI - Your file has few issues. I'd suggest you start with clean workbook.

1. Unnecessary fill color applied to entire sheet in Control Panel.
Instead of fill color, go to "View" ribbon tool and uncheck Grid. This will reduce resource overhead.

2. You have Counter, Start, End form control in AX:BC range.
I don't see the purpose of this.

3. Again you have unnecessary formats applied in Input.
Only apply format to minimum range needed (only where cell contains value). Otherwise. It will hamper workbook performance.

Also as of note, as number of unique formatting increases in a workbook, it will hamper performance as well. Keep formatting uniform as possible within a workbook. Especially where data entry and analysis co-exist in same workbook.

Edit: Attached is cleaned up version of your sample.

 

[Chihiro]

Had little bit of time this afternoon. Did a sample logic based on x sample per unique Name (column A). I have put in a check to reject sample size (per Name) that's larger than smallest population size (population size = Count of Record for each Name).

Main Code:

Sub RandSample()
Dim arOrig, x, Key, Key1, arRes()
Dim i As Long, j As Long, iSubset As Long
Dim dicRnd As Object, dicSorted As Object, dicUnq As Object, dicRes As Object

If [H6] > [H9] Or [H6] = vbNullString Then
    MsgBox "Sample size cannot exceed minimum population size!!", vbCritical
    [H6].ClearContents
    [H6].Activate
    Exit Sub
End If

iSubset = [H6].Value

With Sheets("Input")
    arOrig = .Range("A2:E" & .Cells(Rows.Count, 1).End(xlUp).Row).Value2
End With

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

Function for sorting dictionary.

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

See attached for demo.

Haven't optimized it, but should give you idea of what's needed.

 

[Aman Semwal]

Thanks a lot for helping me on this...