Using VB to export random rows based on date and name

Question

Hi All

I have been working on a project that monitors tasks being completed by users. An ask on this is that a people leader can use a button in excel, to generate a new sheet that provides 5 random rows for work competed on any given day, (Users will enter date as confirmation of task completion in column 17 and then their name in column 18.)

I have (with the help of the internet) got as far as the following code.

Code:

Sub dualfilter()

' dualfilter Macro
Dim strInput As String
Sheets("Customer Accounts").Select
strInput = InputBox("Enter date which you require a random sample for. Date to be entered in DD/MM/YYYY format. Where you see prompt to confirm deletion of tab, please hit OK")
Selection.AutoFilter
Sheets("Customer Accounts").Range("A:R").AutoFilter Field:=17, Criteria1:= _
strInput
Cells.Select
    Selection.Copy
    Sheets.Add After:=Sheets(Sheets.Count)
    ActiveSheet.Select
    ActiveSheet.Name = "TempExtract"
    Sheets.Add After:=Sheets(Sheets.Count)
    ActiveSheet.Select
    ActiveSheet.Name = "Extractpercentage"
    Sheets("TempExtract").Select
    Range("A1").Select
    ActiveSheet.Paste
  Randomize 'Initialize Random number seed
Dim MyRows() As Integer    ' Declare dynamic array.
Dim numRows, nxtRow, nxtRnd, chkRnd, copyRow As Integer
'Determine Number of Rows in Customer_Accounts Column A
  numRows = Sheets("TempExtract").Range("A" & Rows.Count).End(xlUp).Row
'Allocate 5 elements in Array
    ReDim MyRows(5)
'Create 5 Random numbers and fill array
     For nxtRow = 1 To 5
getNew:
'Generate Random number
      nxtRnd = Int((numRows) * Rnd + 1)
'Check for Header Row number (1)
      If nxtRnd = 1 Then GoTo getNew
'Loop through array, checking for Duplicates
       For chkRnd = 1 To nxtRow
'Get new number if Duplicate is found
        If MyRows(chkRnd) = nxtRnd Then GoTo getNew
       Next
'Add element if Random number is unique
      MyRows(nxtRow) = nxtRnd
     Next
'Loop through Array, copying rows to Sheet5
  For copyRow = 1 To 5
   Sheets("TempExtract").Rows(MyRows(copyRow)).EntireRow.Copy _
    Destination:=Sheets("Extractpercentage").Range("A2")(copyRow, 1)
    Next
  'Copy header row to newly created extract
    Sheets("Customer Accounts").Select
    Rows("1:1").Select
    Selection.Copy
    Sheets("Extractpercentage").Select
    Range("1:1").Select
    ActiveSheet.Paste
    'Delete Temp Extract Sheet as no longer required
    Sheets("TempExtract").Select
    ActiveWindow.SelectedSheets.Delete
    'Rename Exctract percentage with date and time it was created.
    Sheets("Extractpercentage").Select
    Sheets("Extractpercentage").Name = _
    WorksheetFunction.Text(Now(), "m-d-yyyy h_mm_ss am/pm")
    'Autofit columns
    Cells.Select
    Selection.ColumnWidth = 60
    Cells.EntireRow.AutoFit
    Cells.EntireColumn.AutoFit
End Sub

The above codes simply provides 5 random rows regardless of staff name in column 18. I want to generate data based on name and date. Additionally i won't necessarily want the same volume for each staff member. The desired sample will increase/decrease dependent on quality of work. Therefore, i am thinking adjacent to the button on sheet 1 that will start the macro, i can have a table that a people leader will complete with staff name and number of random rows they want extracted. 

Code:

AB1Staff
 namedesired vol outputs2Staff143Staff244Staff365Staff46

Finally, the staff and volume of staff won't be the same everyday, so one day when sample is produced there may only be 1 Staff and on other days there could be 5 staff.

I appreciate this is a chunky big request for support, any feedback and advise will be warmly received.

Thank you in advance.

Answer 1

a button in excel, to generate a new sheet that provides 5 random rows for work competed on any given day, (Users will enter date as confirmation of task completion in column 17 and then their name in column 18.)

I want to generate data based on name and date.

Up to this point I can follow you, but all the following is not comprehensible.

Copy the code below into a new regular module, you can run it from anywhere you like.

Run it a few times, have a look at the output. If you're not satisfied come back and tell me how the output should look like.

Andreas.

Option Explicit

Sub GenerateRandomSample()

  Dim sDate As String, sName As String

  Dim dDate As Date

  Dim Data, Possible, This

  Dim i As Long, j As Long

  Dim Ws As Worksheet

  'Get a valid user input

  Do

    sDate = InputBox("Enter date", "Generate Random Sample")

    If sDate = "" Then Exit Sub

    If Not IsDate(sDate) Then Beep

  Loop Until IsDate(sDate)

  dDate = sDate

  sName = InputBox("Enter name", "Generate Random Sample")

  If sName = "" Then Exit Sub

  'Read in all data

  Data = Sheets("Customer Accounts").Range("A1").CurrentRegion.Value

  'Initialize

  Possible = Array()

  j = -1

  'Collect all row numbers that are possible

  For i = 2 To UBound(Data)

    If (Data(i, 17) = dDate) And (Data(i, 18) = sName) Then

      j = j + 1

      ReDim Preserve Possible(0 To j)

      Possible(j) = i

    End If

  Next

  'Found any?

  If j < 0 Then

    MsgBox "No match found for " & dDate & " - " & sName, vbExclamation, "Generate Random Sample"

    Exit Sub

  End If

  'More than 5?

  If j > 4 Then

    'Get 5 random rows of the possible rows

    Randomize

    ReDim This(0 To 4)

    For i = 0 To 4

      This(i) = Possible(RandomUnique(0, j, i = 0))

    Next

  Else

    'Just this

    This = Possible

  End If

  'Copy the rows to the top

  For i = 0 To UBound(This)

    For j = 1 To UBound(Data, 2)

      Data(i + 2, j) = Data(This(i), j)

    Next

  Next

  'Output

  Set Ws = Worksheets.Add(After:=Sheets(Sheets.Count))

  Ws.Range("A1").Resize(UBound(This) + 2, UBound(Data, 2)).Value = Data

End Sub

Private Function RandomUnique(ByVal Lo As Long, ByVal Hi As Long, _

    Optional Reset As Boolean = False) As Long

  Static Dict As Object 'Dictionary

  'Init dictionary if necessary

  If Dict Is Nothing Then Set Dict = CreateObject("Scripting.Dictionary")

  'Remove all used numbers if forced from outside

  If Reset Then Dict.RemoveAll

  Do

    'Get a random number

    RandomUnique = Int((Hi - Lo + 1) * Rnd) + Lo

    'Already used?

  Loop Until Not Dict.Exists(RandomUnique)

  'Remember it

  Dict.Add RandomUnique, 0

  'Automatic reset if all numbers used

  If Dict.Count > Hi - Lo Then Dict.RemoveAll

End Function

Answer 2

I am in awe.

All things are easy when you know how it is done. ;-)

Replace all code you have with the code below. Any questions?

Andreas.

Option Explicit

Sub GenerateRandomSample()

  Static sDate As String, sName As String

  Dim dDate As Date

  Dim Data, Possible, This

  Dim i As Long, j As Long

  Dim Ws As Worksheet

  Static Amount As Long

  Dim SheetName As String

  'Get a valid user input

  Do

    sDate = InputBox("Enter date", "Generate Random Sample", sDate)

    If sDate = "" Then Exit Sub

    If Not IsDate(sDate) Then Beep

  Loop Until IsDate(sDate)

  dDate = sDate

  sName = InputBox("Enter name", "Generate Random Sample", sName)

  If sName = "" Then Exit Sub

  If Amount = 0 Then

    Amount = 5 'Default

  Else

    Amount = Amount + 1 'Adjust from last call (see code below)

  End If

  Amount = Application.InputBox("Enter amount", "Generate Random Sample", Amount, Type:=1)

  If Amount <= 0 Then Exit Sub

  'Read in all data

  Data = Sheets("Customer Accounts").Range("A1").CurrentRegion.Value

  'Initialize

  Amount = Amount - 1

  Possible = Array()

  j = -1

  'Collect all row numbers that are possible

  For i = 2 To UBound(Data)

    If (Data(i, 17) = dDate) And (Data(i, 18) = sName) Then

      j = j + 1

      ReDim Preserve Possible(0 To j)

      Possible(j) = i

    End If

  Next

  'Found any?

  If j < 0 Then

    MsgBox "No match found for " & dDate & " - " & sName, vbExclamation, "Generate Random Sample"

    Exit Sub

  End If

  'More than 5?

  If j > Amount Then

    'Get 5 random rows of the possible rows

    Randomize

    ReDim This(0 To Amount)

    For i = 0 To Amount

      This(i) = Possible(RandomUnique(0, j, i = 0))

    Next

  Else

    'Just this

    This = Possible

  End If

  'Copy the rows to the top

  For i = 0 To UBound(This)

    For j = 1 To UBound(Data, 2)

      Data(i + 2, j) = Data(This(i), j)

    Next

  Next

  'Output

  SheetName = NewSheetName(sName & " " & Format(dDate, "dd/mm/yyyy"))

  Set Ws = Worksheets.Add(After:=Sheets(Sheets.Count))

  Ws.Range("A1").Resize(UBound(This) + 2, UBound(Data, 2)).Value = Data

  Ws.Name = SheetName

End Sub

Private Function RandomUnique(ByVal Lo As Long, ByVal Hi As Long, _

    Optional Reset As Boolean = False) As Long

  Static Dict As Object 'Dictionary

  'Init dictionary if necessary

  If Dict Is Nothing Then Set Dict = CreateObject("Scripting.Dictionary")

  'Remove all used numbers if forced from outside

  If Reset Then Dict.RemoveAll

  Do

    'Get a random number

    RandomUnique = Int((Hi - Lo + 1) * Rnd) + Lo

    'Already used?

  Loop Until Not Dict.Exists(RandomUnique)

  'Remember it

  Dict.Add RandomUnique, 0

  'Automatic reset if all numbers used

  If Dict.Count > Hi - Lo Then Dict.RemoveAll

End Function

Private Function ValidSheetName(ByVal SheetName As String) As String

  'Removes invalid chars from Sheetname

  Const InvalidChars = ":/?*[]"

  Dim i As Integer

  For i = 1 To Len(InvalidChars)

    SheetName = Replace(SheetName, Mid(InvalidChars, i, 1), "")

  Next

  ValidSheetName = Mid(SheetName, 1, 31)

End Function

Private Function SheetExists(ByVal SheetNameOrIndex As Variant, _

    Optional ByVal Wb As Workbook = Nothing) As Boolean

  'True if sheet SheetNameOrIndex exists

  On Error Resume Next

  If Wb Is Nothing Then Set Wb = ActiveWorkbook

  SheetExists = Not Wb.Sheets(SheetNameOrIndex) Is Nothing

End Function

Private Function NewSheetName(ByVal SheetName As String, _

    Optional ByVal Wb As Workbook = Nothing) As String

  'Returns a non existing sheet name that begins with SheetName

  Dim i As Long, LeftParen As Long

  Dim NewName As String, SheetExt As String, Blank As String

  SheetName = ValidSheetName(SheetName)

  NewName = SheetName

  If Wb Is Nothing Then Set Wb = ActiveWorkbook

  If SheetExists(SheetName, Wb) Then

    LeftParen = InStrRev(SheetName, "(")

    Blank = " "

    If LeftParen Then

      If SheetName Like "*(" & String(Len(SheetName) - LeftParen - 1, "#") & ")" Then

        i = Mid$(SheetName, LeftParen + 1, Len(SheetName) - LeftParen - 1)

        SheetName = Left$(SheetName, LeftParen - 1)

        Blank = ""

      End If

    End If

    Do

      i = i + 1

      SheetExt = Blank & "(" & i & ")"

      If Len(SheetName) + Len(SheetExt) > 31 Then

        SheetName = Mid(SheetName, 1, 31 - Len(SheetExt))

        If Len(SheetExt) = 31 Then

          'If this happens, then you do extraordinary things, _

            and should better take GUIDs as sheet names. ;-)

          Err.Raise 6, "NewSheetName"

        End If

      End If

      NewName = SheetName & SheetExt

    Loop Until Not SheetExists(NewName, Wb)

  End If

  NewSheetName = NewName

End Function

Answer 3

Is there a way that the newly created worksheet can be named as per the staff name and date?

Sure, which date format do you like (dd-mm-yyyy or mm-dd-yyyy or whatever)?

Should I rename the sheet with an indice if a sheet already exists or should I delete the old one?

Also the random data sample amount is no problem.

Andreas.

Answer 4

And... I know i am asking so much here, but is there a way that the newly created worksheet can be named as per the staff name and date?

Answer 5

WOW! that is incredible. Totally different from my approach and it is so quick too. Thank you.

Is there a way, that the random data sample amount can be specified in same way that date and name is specified? This would allow smaller samples for users performing well and larger samples for users who need more scrutiny.