Random 12 sample with no duplicates and 1 condition

willow1985

Well-known Member
Joined
Jul 24, 2019
Messages
718
Office Version
  1. 365
Platform
  1. Windows
Hello

I need help with acquiring a random 12 numbers from Column A in the blue table (right). No numbers can be duplicated on the list (column A on the left) and I need the formula to only select Work Order numbers that have an "N" in column E in the table (right)

(see below picture)

I hope I am explaining this well...

1603833016820.png


Thank you to anyone who can help :)

Carla
 

willow1985

Well-known Member
Joined
Jul 24, 2019
Messages
718
Office Version
  1. 365
Platform
  1. Windows
You took out too much... you removed the entire loop where as I only wanted you to remove the part I showed you from the single code line inside the loop. Here is the entire macro with the changes (including your cell reference) in place...
VBA Code:
Sub Carla()
  Dim R As Long, Cnt As Long, RandomIndex As Long, HowMany As Long, Arr As Variant, Tmp As Variant
  HowMany = Sheets("Random Sample").Range("C1").Value
  Randomize
  Arr = Sheets("Sheet1").ListObjects("Table").DataBodyRange.Value
  With CreateObject("Scripting.Dictionary")
    For R = 1 To UBound(Arr)
      .Item(CStr(Arr(R, 1))) = 1
    Next
    Arr = .Keys
  End With
  For Cnt = UBound(Arr) To LBound(Arr) Step -1
    RandomIndex = Int((Cnt - LBound(Arr) + 1) * Rnd + LBound(Arr))
    Tmp = Arr(RandomIndex)
    Arr(RandomIndex) = Arr(Cnt)
    Arr(Cnt) = Tmp
  Next
  Sheets("Sheet2").Range("A3").Resize(HowMany) = Application.Transpose(Arr)
End Sub
NOTE: I did not include the test you added at the beginning of my macro. I would point out that it seems overly complicated for what I think it is doing. It looks like you should be able to test the cell for being empty and accomplish the same thing I think you are trying to do. If I am right, this would be my suggestion for the If..Then test...

If Sheets("Random Sample").Range("E1").Value = "" Then

I apologize, I had to do a ton of modifications due to multiple requests from my boss (including adding in the "Y" condition) but I am getting a mismatch error again.

If you could let me know what I am missing I should be good. Everything was working until I had to add back in the If Arr(R,5) = "Y"

VBA Code:
Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Sub RS()
'
' RS Macro
'
 
        If Application.CountIf(Sheets("Random Sample").Range("E1"), "") > 0 Then
        MsgBox "Please Enter User Name"
        Exit Sub
    End If
      If Application.CountIf(Sheets("Random Sample").Range("C1"), "") > 0 Then
        MsgBox "Please Enter Sample Size"
        Exit Sub
    End If
      If Application.CountIf(Sheets("Random Sample").Range("F1:I1"), "") > 0 Then
        MsgBox "Please Enter Date Range"
        Exit Sub
    End If

Application.ScreenUpdating = False
   
Sheets("Table").Visible = True
Sheets("DATA").Visible = True

Sheets("Table").Select
For Each lo In ActiveSheet.ListObjects
lo.AutoFilter.ShowAllData
      Next lo
      If (ActiveSheet.AutoFilterMode And ActiveSheet.FilterMode) Or ActiveSheet.FilterMode Then
  ActiveSheet.ShowAllData
End If

     Range("A3:E" & Cells(Rows.Count, 1).End(xlUp).Row).EntireRow.Delete
Range("A3").Select

Sheets("DATA").Range("A1:D1000000").ListObject.QueryTable.Refresh BackgroundQuery:=False
Sleep 2
DoEvents

    Range("A2:D" & Cells(Rows.Count, 1).End(xlUp).Row).Select
    Selection.Copy

Sheets("Table").Select
    Range("A2").Select
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False
    Calculate
    DoEvents
    Sheets("Table").Visible = False
Sheets("DATA").Visible = False
Sheets("Random Sample").Select
   
ActiveSheet.Range("A3:A" & Range("A3").End(xlDown).Row).ClearContents
ActiveSheet.Range("B3:B" & Range("B3").End(xlDown).Row).ClearContents
 
  Dim R As Long, Cnt As Long, RandomIndex As Long, HowMany As Long, Arr As Variant, Tmp As Variant
  HowMany = Sheets("Random Sample").Range("C1").Value
  Randomize
  Arr = Sheets("Table").ListObjects("WO").DataBodyRange.Value
  With CreateObject("Scripting.Dictionary")
    For R = 1 To UBound(Arr)
    If Arr(R, 5) = "Y" Then .Item(CStr(Arr(R, 1))) = 1
    Next
    Arr = .Keys
  End With
  For Cnt = UBound(Arr) To LBound(Arr) Step -1
    RandomIndex = Int((Cnt - LBound(Arr) + 1) * Rnd + LBound(Arr))
    Tmp = Arr(RandomIndex)
    Arr(RandomIndex) = Arr(Cnt)
    Arr(Cnt) = Tmp
  Next
  Sheets("Random Sample").Range("B3").Resize(HowMany) = Application.Transpose(Arr)
 
Dim MyRange As Range
Dim LastRow As Long

LastRow = ActiveSheet.Range("B" & Rows.Count).End(xlUp).Row
Set MyRange = ActiveSheet.Range("B3:B" & LastRow)

ActiveWorkbook.Worksheets("Random Sample").Sort.SortFields.Add2 Key:=Range( _
        "B3"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortTextAsNumbers
    With ActiveWorkbook.Worksheets("Random Sample").Sort
        .SetRange MyRange
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

   Range("A3").Select
LastRowColumnB = Cells(Rows.Count, 2).End(xlUp).Row
    Range("A3:A" & LastRowColumnB).Formula = "=MATCH(RC[1],DATA!C,0)"

Application.ScreenUpdating = True


End Sub
 

Excel Facts

When they said...
When they said you are going to "Excel at life", they meant you "will be doing Excel your whole life".

willow1985

Well-known Member
Joined
Jul 24, 2019
Messages
718
Office Version
  1. 365
Platform
  1. Windows
Or should I put this question in a new post?
 

willow1985

Well-known Member
Joined
Jul 24, 2019
Messages
718
Office Version
  1. 365
Platform
  1. Windows
I don't think my error is related to the code you provided so I will close this post and start a new one as I think it is something unrelated.

Thank you very much!!
 

Peter_SSs

MrExcel MVP, Moderator
Joined
May 28, 2005
Messages
48,474
Office Version
  1. 365
Platform
  1. Windows
You can replace the above three lines of code from you macro with this single line of code and it will work the same...
VBA Code:
Sheets("Sheet2").Range("A3:A14").Value = Application.Transpose(Filter(Split(Join(AL.ToArray, "|"), "|"), "#", False))
Here the receiving range limits the input to the first 12 items in the array so there is no need to ReDim Preserve to accomplish this same outcome.
Thanks for the suggestion Rick but I would prefer to leave it as is
- I see no inherent value in writing less lines
- If there are less than 12 items meeting the criteria, I prefer to simply get that smaller list rather than a range padded out with error values.
 

Rick Rothstein

MrExcel MVP
Joined
Apr 18, 2011
Messages
36,970
Office Version
  1. 2016
Platform
  1. Windows

ADVERTISEMENT

Well then, you could leave the assignment to the array variable as you had it but eliminate the ReDim Preserve (not one of VB's fastest operations) and just assign the array to the output range directly.
 

Peter_SSs

MrExcel MVP, Moderator
Joined
May 28, 2005
Messages
48,474
Office Version
  1. 365
Platform
  1. Windows
Well then, you could leave the assignment to the array variable as you had it but eliminate the ReDim Preserve (not one of VB's fastest operations) and just assign the array to the output range directly.
I'm not sure I follow. What code are you suggesting?
Since this is not in a loop as far as we know I don't see a speed issue with doing a single Redim Preserve.
 

Rick Rothstein

MrExcel MVP
Joined
Apr 18, 2011
Messages
36,970
Office Version
  1. 2016
Platform
  1. Windows

ADVERTISEMENT

No, there is no substantial speed issue without a loop, of course, all I was saying is ReDim Preserve is not the most efficient functionality in VB and for the outcome you were seeking, using it was unnecessary. If you assign the array to a restricted range of cells, only the "top, left" values from the array will be assigned to the range... that is the same functionality you get by first ReDim Preserve'ing the array prior to making the assignment.
 

willow1985

Well-known Member
Joined
Jul 24, 2019
Messages
718
Office Version
  1. 365
Platform
  1. Windows
No, there is no substantial speed issue without a loop, of course, all I was saying is ReDim Preserve is not the most efficient functionality in VB and for the outcome you were seeking, using it was unnecessary. If you assign the array to a restricted range of cells, only the "top, left" values from the array will be assigned to the range... that is the same functionality you get by first ReDim Preserve'ing the array prior to making the assignment.
I am not sure I am following you guys, do you know the cause of the mismatch error in the most recent code posted? I am still stumped with this...
 

Rick Rothstein

MrExcel MVP
Joined
Apr 18, 2011
Messages
36,970
Office Version
  1. 2016
Platform
  1. Windows
Your last post (#13) said you were closing this "post" (which I took to mean this thread) and would start a new one. So I did not think you were looking for a further response here nor am I sure we know all of your code for this project so we might not know how to respond without more information. Did you start a new thread yet?
 

Peter_SSs

MrExcel MVP, Moderator
Joined
May 28, 2005
Messages
48,474
Office Version
  1. 365
Platform
  1. Windows
all I was saying is ReDim Preserve is not the most efficient functionality in VB and for the outcome you were seeking, using it was unnecessary.
Oh, I thought you were offering an alternative for the case where there were fewer than 12 results matching the criteria & still avoiding the error value.
 

Watch MrExcel Video

Forum statistics

Threads
1,129,387
Messages
5,636,018
Members
416,892
Latest member
Bensch

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
Top