VBA to randomly extract rows based on multiple conditions

nagasree

New Member
Joined
Oct 30, 2021
Messages
30
Office Version
  1. 2019
Platform
  1. Windows
I have a audited file, I need to extract some rows and paste it on another sheet based on multiple conditions,

The excel sheet has auditor name in column A, region in column C and decision in column T(column T has multiple values such as valid, Invalid, etc, to be selected using dropdowns.)

I need a vba code which should extract 27 rows for each person's each region(each person works on muliple regions) which must contain all valid decisions and the remaining rows can be randomly selected from remaining decisions.


So finally if a person A works on 2 regions, us and uk, the final output must have 27 rows for A person's Us and 27 rows for A person's Uk and similarly every person's rows.

Please help me with this, Thanks in advance
 

Excel Facts

Difference between two dates
Secret function! Use =DATEDIF(A2,B2,"Y")&" years"&=DATEDIF(A2,B2,"YM")&" months"&=DATEDIF(A2,B2,"MD")&" days"
paste code into a module then run : RunData
kiPULLQTY = 27 will give you 27 rows for each person / each region

Code:
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
 
Upvote 0
paste code into a module then run : RunData
kiPULLQTY = 27 will give you 27 rows for each person / each region

Code:
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
Thanks, but in 27 rows, it must contain all "valid" marked rows and the remaining random rows,

For example, if a person A in region US has marked 10 valid, 30 invalid, 5 correct, 15 incorrect in decision column, then all 10 valid rows must be selected and the remaining 17 can be randomly selected from other decisions, can you change code like that please???
 
Upvote 0
paste code into a module then run : RunData
kiPULLQTY = 27 will give you 27 rows for each person / each region

Code:
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
Hello, Actually it is not working, it is just filtering all the based on persons, its not extracting 27 rows
 
Upvote 0

Forum statistics

Threads
1,213,536
Messages
6,114,210
Members
448,554
Latest member
Gleisner2

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top