Option Explicit
Public gcolNames As Collection
Public Const kiPULLQTY = 27
Public Const kiColREG = 3
Public giMarker As Long
Public rng As Range
Public Sub RunData()
LoadNames
MakeResults
End Sub
Private Sub AuditList()
Dim iRows As Long
On Error Resume Next
Sheets("Results").Delete
Sheets("Auditors").Delete
Sheets("Data").Select
'Sheets.Add
'ActiveSheet.Name = "results"
Sheets.Add
ActiveSheet.Name = "auditors"
Sheets("Data").Select
Columns("A:A").Select
Selection.Copy
Sheets("auditors").Select
ActiveSheet.Paste
Application.CutCopyMode = False
Range("A1").Select
iRows = ActiveSheet.UsedRange.Rows.Count
ActiveSheet.Range("$A$1:$A$" & iRows).RemoveDuplicates Columns:=1, Header:=xlYes
LoadNames
End Sub
'load the auditors
Private Sub LoadNames()
Dim sName As String
On Error Resume Next
Set gcolNames = New Collection
Sheets("auditors").Select
Range("A2").Select
While ActiveCell.Value <> ""
sName = ActiveCell.Value
gcolNames.Add sName, sName
ActiveCell.Offset(1, 0).Select 'next row
Wend
Sheets("Data").Select
Range("A1").Select
End Sub
Private Sub MakeResults()
Dim i As Integer
Dim vName
Sheets("Data").Select
Range("A1").Select
For i = 1 To gcolNames.Count
vName = gcolNames(i)
Set rng = ActiveSheet.UsedRange
Selection.AutoFilter
rng.AutoFilter Field:=1, Criteria1:=vName
GoSub PostResults
Sheets("Data").Select
Selection.AutoFilter 'filter off
Next
Sheets("Data").Select
Selection.AutoFilter
Exit Sub
'-----------
PostResults:
'-----------
Set rng = ActiveSheet.UsedRange
rng.Copy
Sheets.Add
ActiveSheet.Name = vName
'Sheets(vName).Activate
ActiveCell.PasteSpecial xlPasteAll
Application.CutCopyMode = False
Range("A1").Select
PickRandom
Return
End Sub
Private Sub PickRandom()
Dim iRows As Long, r As Long
Dim colRows As New Collection, colRegions As New Collection
Dim i As Integer, iMarked As Integer, g As Integer
Dim vReg, vCell1, vCell2, x
On Error Resume Next
'add marker fld
Range("A1").Select
Selection.End(xlToRight).Select
If ActiveCell.Value <> "MARK" Then
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = "MARK"
End If
giMarker = ActiveCell.Column
'load eligible rows
Set colRows = New Collection
Range("A2").Select
iRows = ActiveSheet.UsedRange.Rows.Count
Range("A1").Select
vCell2 = Range("A1").Offset(iRows - 1, giMarker - 1).Address
vCell1 = Left(vCell2, InStr(Mid(vCell2, 2), "$")) & "2"
Range(vCell1 & ":" & vCell2).ClearContents
For r = 2 To iRows
colRows.Add r
Next
'collect regions
Set colRegions = New Collection
Range("A2").Select
While ActiveCell.Value <> ""
vReg = ActiveCell.Offset(0, 2).Value 'get region in col.C
colRegions.Add vReg, vReg
ActiveCell.Offset(1, 0).Select 'next row
Wend
'mark random records
For g = 1 To colRegions.Count
iMarked = 0
vReg = colRegions(g)
'filter on the region
Set rng = ActiveSheet.UsedRange
Selection.AutoFilter
rng.AutoFilter Field:=kiColREG, Criteria1:=vReg
'what if we dont have enough records
If ActiveSheet.UsedRange.SpecialCells(xlCellTypeVisible).Rows.Count <= kiPULLQTY Then Exit Sub
'pick random
While iMarked < kiPULLQTY
Range("A1").Select
x = Int((colRows.Count * Rnd) + 1)
r = colRows(x)
If Cells(r, kiColREG) = vReg Then
Cells(r, giMarker) = "X"
colRows.Remove x
iMarked = iMarked + 1
End If
Wend
Next
'Selection.AutoFilter
'filter
Set rng = ActiveSheet.UsedRange
Selection.AutoFilter
rng.AutoFilter Field:=giMarker, Criteria1:="X"
End Sub