VBA: Random selection from list, no duplicates

[Noodle123]

I am using the below code (provided by Tigeravitar) to randomly select statements to be audited and it is working perfectly with one exception:
There is nothing in the code to keep from selecting the same statement twice. I need to randomly select X number of statements without any duplicates.
I'm hoping there is a quick tweak that can solve this issue....but I've been searching through several forums and haven't had any luck yet.
Any ideas you may have would be greatly appreciated! Thank you!
Below is the code I am currently using which runs perfectly, but occasionally returns duplicates:

Sub EStmtAudit()

Dim wsEstmt As Worksheet
Dim wsEMas As Worksheet
Dim rngFound As Range
Dim arrResults() As Variant
Dim strNames As String
Dim lNumNames As Long
Dim i As Long, r As Long

Worksheets("Electronic Statements").Select 'Selects the "Electronic Statements" tab
TotRow = Range("D" & Rows.Count).End(xlUp).Row 'Finds bottom row of data
Range("D2:D" & TotRow).Copy 'Identifies range to copy & copies
Range("B2").PasteSpecial Paste:=xlPasteValues 'Identifies where to place first cell of data & pastes results as values




lNumNames = Int(Application.InputBox("How many statements will be audited?", "Number of Audits", 5, Type:=1))
If lNumNames <= 0 Then Exit Sub 'Invalid entry or pressed cancel

Set wsEstmt = Sheets("Electronic Statements")
Set wsEMas = Sheets("Electronic Stmt Audit Master")

With wsEstmt.Range("B2", wsEstmt.Cells(Rows.Count, "B").End(xlUp))
strNames = Join(Filter(Application.Transpose(Evaluate("If('" & .Parent.Name & "'!" & .Offset(, 1).Address & "<>""X"",'" & .Parent.Name & "'!" & .Address & ")")), False, False), "|")
End With

If Len(strNames) > 0 Then
If lNumNames <= (Len(strNames) - Len(Replace(strNames, "|", vbNullString)) + 1) Then
ReDim arrResults(1 To lNumNames, 1 To 3)
strNames = "|" & strNames & "|"
For i = 1 To lNumNames
r = Int(Rnd() * (Len(strNames) - Len(Replace(strNames, "|", vbNullString)) - 1)) + 1
Set rngFound = wsEstmt.Cells.Find(Trim(Mid(Replace(strNames, "|", String(255, " ")), 255 * r, 255)))
arrResults(i, 1) = i
arrResults(i, 2) = wsEstmt.Cells(rngFound.Row, "A").Text
arrResults(i, 3) = wsEstmt.Cells(rngFound.Row, "B").Text
strNames = Replace(strNames, "|" & rngFound.Text & "|", "|")
Next i
Intersect(wsEMas.Range("A2", wsEMas.Cells(Rows.Count, Columns.Count)), wsEMas.Columns("A").Resize(, UBound(arrResults, 2)).EntireColumn).ClearContents
wsEMas.Range("A2").Resize(UBound(arrResults, 1), UBound(arrResults, 2)).Value = arrResults
Else
MsgBox Title:="Entry Too High", _
Prompt:="There are not [" & lNumNames & "] statements that can be audited." & vbNewLine & _
"The maximum number that can be audited is: " & Len(strNames) - Len(Replace(strNames, "|", vbNullString)) + 1
End If
Else
MsgBox "No statements found that are available for auditing"
End If

Set wsEstmt = Nothing
Set wsEMas = Nothing
Set rngFound = Nothing
Erase arrResults

End Sub

 

[Leith Ross]

Hello NatalieBuck3,

This version of the macro will prevent duplicates.

Sub EStmtAudit()


    Dim Used        As New Collection
    Dim wsEstmt     As Worksheet
    Dim wsEMas      As Worksheet
    Dim rngFound    As Range
    Dim arrResults() As Variant
    Dim strNames    As String
    Dim lNumNames   As Long
    Dim i As Long, r As Long


        Worksheets("Electronic Statements").Select 'Selects the "Electronic Statements" tab
        TotRow = Range("D" & Rows.Count).End(xlUp).Row 'Finds bottom row of data
        
        Range("D2:D" & TotRow).Copy 'Identifies range to copy & copies
        Range("B2").PasteSpecial Paste:=xlPasteValues 'Identifies where to place first cell of data & pastes results as values


        lNumNames = Int(Application.InputBox("How many statements will be audited?", "Number of Audits", 5, Type:=1))
        If lNumNames <= 0 Then Exit Sub 'Invalid entry or pressed cancel


        Set wsEstmt = Sheets("Electronic Statements")
        Set wsEMas = Sheets("Electronic Stmt Audit Master")


            With wsEstmt.Range("B2", wsEstmt.Cells(Rows.Count, "B").End(xlUp))
                strNames = Join(Filter(Application.Transpose(Evaluate("If('" & .Parent.Name & "'!" & .Offset(, 1).Address & "<>""X"",'" & .Parent.Name & "'!" & .Address & ")")), False, False), "|")
            End With


            If Len(strNames) > 0 Then
                If lNumNames <= (Len(strNames) - Len(Replace(strNames, "|", vbNullString)) + 1) Then
                    ReDim arrResults(1 To lNumNames, 1 To 3)
                    strNames = "|" & strNames & "|"
                    For i = 1 To lNumNames
RandomNumber:
                        r = Int(Rnd() * (Len(strNames) - Len(Replace(strNames, "|", vbNullString)) - 1)) + 1
                        On Error Resume Next
                            Used.Add 1, Str(r)
                            If Err = 457 Then
                                On Error GoTo 0
                                GoTo RandomNumber
                            End If
                        On Error GoTo 0
                        
                        Set rngFound = wsEstmt.Cells.Find(Trim(Mid(Replace(strNames, "|", String(255, " ")), 255 * r, 255)))
                        arrResults(i, 1) = i
                        arrResults(i, 2) = wsEstmt.Cells(rngFound.Row, "A").Text
                        arrResults(i, 3) = wsEstmt.Cells(rngFound.Row, "B").Text
                        strNames = Replace(strNames, "|" & rngFound.Text & "|", "|")
                    Next i
                    Intersect(wsEMas.Range("A2", wsEMas.Cells(Rows.Count, Columns.Count)), wsEMas.Columns("A").Resize(, UBound(arrResults, 2)).EntireColumn).ClearContents
                    wsEMas.Range("A2").Resize(UBound(arrResults, 1), UBound(arrResults, 2)).Value = arrResults
                Else
                    MsgBox Title:="Entry Too High", _
                    Prompt:="There are not [" & lNumNames & "] statements that can be audited." & vbNewLine & _
                    "The maximum number that can be audited is: " & Len(strNames) - Len(Replace(strNames, "|", vbNullString)) + 1
                End If
            Else
                MsgBox "No statements found that are available for auditing"
            End If


        Set wsEstmt = Nothing
        Set wsEMas = Nothing
        Set rngFound = Nothing
        Erase arrResults


End Sub

 

[Noodle123]

Wow, that was quick! Thank you so much! I will try running this code really quick and respond shortly with the results!

 

[Noodle123]

Works like a charm. You are a genius! Thanks for all of your help on this.

 

[Noodle123]

Perhaps I spoke too soon, I am still getting a few duplicates.
I will continue to try and tweak this, thank you so much for pointing me in the right direction.
Once I find the code that works, I will definitely share it on this post!