Consulting

Results 1 to 20 of 66

Thread: Help Required : Random Sampling of Data

Threaded View

Previous Post Previous Post   Next Post Next Post
  1. #1
    VBAX Mentor
    Joined
    Nov 2020
    Location
    Cochin, Kerala
    Posts
    314
    Location

    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.


    1. The code shall work for the entire selection range (currently only 5 columns).
    2. 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.
    3. 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

    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
    Attached Files Attached Files

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •