Random 12 sample with no duplicates and 1 condition

[willow1985]

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...

Thank you to anyone who can help

Carla

 

[willow1985]

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...

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"

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

 

[willow1985]

Or should I put this question in a new post?

 

[willow1985]

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]

You can replace the above three lines of code from you macro with this single line of code and it will work the same...

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]

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]

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]

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]

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]

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]

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.