Random Selection. Is it Possible

I would like vba code that will randomly select 15% of items, is it possible ?

So In column E are the 'Type' so there are Apples 17 Leeks 14 etc.

In column N I want to put the word 'check' against 15% of each 'Type.

So for Apples I would select 3, for Leek I would select 2 etc.

Of course the names would change all the time so I am thinking that it should be based on say the first 4 letters in each cell in column E, so like Appl, Leek, Oran etc etc.

I have attached a file to [hopefully] show it more clearly.

Thanks
Random-Check.xlsx
JagwarmanAsked:
Who is Participating?

[Product update] Infrastructure Analysis Tool is now available with Business Accounts.Learn More

x
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

Martin LissOlder than dirtCommented:
When you say "select 15% of items", what do you want to do with them?
JagwarmanAuthor Commented:
In column N I want to put the word 'check' against 15% of each 'Type
Glenn RayExcel VBA DeveloperCommented:
Yes, it's possible.  I've written code for audit checks that do this very thing (i.e., randomly select a percentage or count of transactions for spot check).

Can you clarify:  you want AT LEAST 15% of each "Type" value in column E to be flagged with "Check" in column N?  The formula on your "15% Totals needed" sheet would then be:
=ROUNDUP(G4*0.15,0)

and the total checked would increase from "9" (actually 8.85) to 12.

-Glenn
Starting with Angular 5

Learn the essential features and functions of the popular JavaScript framework for building mobile, desktop and web applications.

Martin LissOlder than dirtCommented:
Try this. It assumes that column "U" is unused. This solution doesn't care what the names are.

Sub UniqueValues()
Dim intCount As Integer
Dim int15 As Integer
Dim lngRow As Long
Dim intRandomRow As Integer
Dim colRows As Collection
Dim lngLastRowE As Long


With Sheets("Data")
    lngLastRowE = .Range("E1048576").End(xlUp).Row
    .Range("E2:E" & lngLastRowE).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=.Range("U2"), Unique:=True
    ' For some unknown reason the AdvancedFilter creates a duplicate value in the last row, so
    ' delete it.
    .Cells(.Range("U1048576").End(xlUp).Row, "U").Delete
    For lngRow = 2 To .Range("U1048576").End(xlUp).Row
        ' calculate 15% of each unique value in column E
        int15 = Application.CountIf(.Range("E2:E" & lngLastRowE), .Cells(lngRow, "U")) * 0.15
        Set colRows = New Collection
        Do Until colRows.Count = int15
            ' Generate a random row number
            intRandomRow = Int((lngLastRowE - 2 + 1) * Rnd + 2)
            On Error Resume Next
            ' Only unique values are added to the collection
            colRows.Add intRandomRow, CStr(intRandomRow)
            On Error GoTo 0
        Loop
        ' Add the "check" values
        For intRandomRow = 1 To colRows.Count
            .Cells(colRows(intRandomRow), "N") = "check"
        Next
    Next
    Range("U:U").ClearContents
End With
End Sub

Open in new window

Glenn RayExcel VBA DeveloperCommented:
I tried Martin's code, but it doesn't always flag 15% of each type.  This is because the code is adding to the collection using all the rows as a base data set and also skips re-applying a new row if an existing row is already in the collection.

I opted for a more "brute force" method.  I'm following Martin's method of generating the unique list of Types, but after that I'm calculating a RoundUp value of 15% of the CountIf result and then am generating a random row and testing the Type match and whether the row is already flagged ("check").
Option Explicit
Sub Flag_15Pct()
    Dim int15, r, x As Integer
    Dim strType As String
    Dim lngRandRow, lngTypeRow, lngRowE As Long
    Dim boolFlag As Boolean
    
    Application.ScreenUpdating = False
    Sheets("Data").Select
    lngRowE = Cells(Rows.Count, 5).End(xlUp).Row
    Range("N2:N" & lngRowE).ClearContents
    Range("U2:U" & lngRowE).ClearContents 'reset unique values and Random Row list
    Range("E2:E" & lngRowE).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("U2"), Unique:=True
    ' For some unknown reason the AdvancedFilter creates a duplicate value
    'in the last row, so delete it.
    Range("U2").End(xlDown).Delete 'no blank values in unique list, so top-down
    
    For r = 2 To Range("U2").End(xlDown).Row
        strType = Cells(r, "U").Value
        ' calculate 15% of each unique value in column E
        int15 = Application.WorksheetFunction.RoundUp((Application.WorksheetFunction.CountIf(Range("E2:E" & lngRowE), strType) * 0.15), 0)
        For x = 1 To int15
            boolFlag = False
            ' Generate a random row number
            Do
                lngRandRow = Application.WorksheetFunction.RandBetween(2, lngRowE)
                If Cells(lngRandRow, "E") = strType And Cells(lngRandRow, "N") <> "check" Then
                    Cells(lngRandRow, "N") = "check"
                    boolFlag = True
                End If
            Loop Until boolFlag
        Next x
     Next r
     Range("U:U").ClearContents
     Sheets(2).Select
     Application.ScreenUpdating = True
End Sub

Open in new window


I've attached a workbook showing both methods; form buttons activate each macro on the second sheet.

Regards,
-Glenn
EE-Random-Check.xlsm

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
Martin LissOlder than dirtCommented:
I tried Martin's code, but it doesn't always flag 15% of each type.  This is because the code is adding to the collection using all the rows as a base data set and also skips re-applying a new row if an existing row is already in the collection.
But that's the way it should work. The rnd function generates a row number and the use of the CStr(intRandomRow) as a key to the collection entry and the On error Resume Next assures that only unique row numbers get added to the collection. The adding stops when 15% of, say, the count of "Apples" is reached. There is a mistake in my code however and that is that I didn't consider the value in the cell I was randomly selecting. This fixes that.
Sub UniqueValues()
Dim intCount As Integer
Dim int15 As Integer
Dim lngRow As Long
Dim intRandomRow As Integer
Dim colRows As Collection
Dim lngLastRowE As Long


With Sheets("Data")
    lngLastRowE = .Range("E1048576").End(xlUp).Row
    .Range("E1:E" & lngLastRowE).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=.Range("U1"), Unique:=True
    For lngRow = 2 To .Range("U1048576").End(xlUp).Row
        ' calculate 15% of each unique value in column E
        int15 = Application.CountIf(.Range("E2:E" & lngLastRowE), .Cells(lngRow, "U")) * 0.15
        Set colRows = New Collection
        Do Until colRows.Count = int15
            ' Generate a random row number
            intRandomRow = Int((lngLastRowE - 2 + 1) * Rnd + 2)
            If .Cells(intRandomRow, "E") = .Cells(lngRow, "U") Then
                On Error Resume Next
                ' Only unique values are added to the collection
                colRows.Add intRandomRow, CStr(intRandomRow)
            End If
            On Error GoTo 0
        Loop
        ' Add the "check" values
        For intRandomRow = 1 To colRows.Count
            .Cells(colRows(intRandomRow), "N") = "check"
        Next
    Next
    Range("U:U").ClearContents
End With
End Sub

Open in new window

Glenn RayExcel VBA DeveloperCommented:
That code does indeed correct the issue of the assignment to the collection for a given Type.  

The only remaining issue would be if the requester wants AT LEAST 15% of each Type flagged, which was my initial question above.  His check sheet was formatting a decimal value and rounding it to a whole number,   Maybe splitting hairs, but important to know.  For example, there are 7 items with Type "Orange".  Flagging only one of them is only 14.3%; if they need at least 15% for each type, then two (2) items have to be flagged.

-Glenn
Martin LissOlder than dirtCommented:
Well on his '15% Totals needed" sheet he shows 1 for  Orange, but in either case thanks for keeping me on my toes.
JagwarmanAuthor Commented:
wow you two are amazing thank you. I am going to have to split 50/50 the points
JagwarmanAuthor Commented:
Both equally as good as each other.
Martin LissOlder than dirtCommented:
You're welcome and I'm glad I was able to help, and I agree that Glenn is one of the good guys.

In my profile you'll find links to some articles I've written that may interest you.
Marty - MVP 2009 to 2015
Glenn RayExcel VBA DeveloperCommented:
Thanks, Martin.  Right back atcha! ;-)

It's problems like these that make EE a fun and educational place.  Cool to see different and valid solutions.

-Glenn
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
Microsoft Excel

From novice to tech pro — start learning today.