CODEWITHSUNDEEP
vbaexcel
sbagnato
sbagnato

Reputation: 496

Excel VBA - Selecting random rows based on multiple criteria

I have the below code set which takes a list of ticket data, and randomly selected three rows based on the username in Col D.

However, with a recent change in our ticketing system, I now need to update it to not select certain tickets. Specifically, I need only INC and SCTASK tickets to be selected, and not RITM tickets.

I am not quite sure how to add the filter so that tickets with RITM in the ticket number (ticket numbers are in Col A) are not included in this search.

Sub DailyTicketAudit()

'Set parameters and variables
    Const sDataSheet As String = "Page 1"
    Const sUserCol As String = "D"
    Const lHeaderRow As Long = 1
    Const lShowRowsPerUser As Long = 3
    Const bSortDataByUser As Boolean = False
    Dim wb As Workbook, ws As Worksheet
    Dim rData As Range, rShow As Range
    Dim aData() As Variant, aUserRows() As Variant
    Dim i As Long, j As Long, k As Long, lRandIndex As Long, lTotalUnqUsers As Long, lMaxUserRows As Long
    Set wb = Workbooks.Open("D:\Users\stefan.bagnato\Desktop\Raw Data Files\Audit Tickets Created")
    Set ws = ActiveWorkbook.Sheets(sDataSheet)
    Sheets("Page 1").name = "Audit Tickets"

'Work with the data range set by parameters
    With ws.Range(sUserCol & lHeaderRow + 1, ws.Cells(ws.Rows.Count, sUserCol).End(xlUp))
        If .Row < lHeaderRow + 1 Then
            MsgBox "No data found in [" & sDataSheet & "]" & Chr(10) & _
                   "Verify column containing users is Column [" & sUserCol & "] or correct sUserCol in code." & Chr(10) & _
                   "Verify header row is Row [" & lHeaderRow & "] or correct lHeaderRow in code." & Chr(10) & _
                   "Once corrections have been made and data is available, try again."
            Exit Sub
        End If
        lTotalUnqUsers = Evaluate("SUMPRODUCT((" & .Address(external:=True) & "<>"""")/COUNTIF(" & .Address(external:=True) & "," & .Address(external:=True) & "&""""))")
        lMaxUserRows = Evaluate("max(countif(" & .Address(external:=True) & "," & .Address(external:=True) & "))")
        If bSortDataByUser Then .Sort .Cells, xlAscending, Header:=xlNo
        Set rData = .Cells
        aData = .Value
        ReDim aUserRows(1 To lTotalUnqUsers, 1 To 3, 1 To lMaxUserRows)
    End With

'Load all available rows into the results array, grouped by the user
    For i = LBound(aData, 1) To UBound(aData, 1)
        For j = LBound(aUserRows, 1) To UBound(aUserRows, 1)
            If IsEmpty(aUserRows(j, 1, 1)) Or aUserRows(j, 1, 1) = aData(i, 1) Then
                If IsEmpty(aUserRows(j, 1, 1)) Then aUserRows(j, 1, 1) = aData(i, 1)
                k = aUserRows(j, 2, 1) + 1
                aUserRows(j, 2, 1) = k
                aUserRows(j, 3, k) = i + lHeaderRow
                Exit For
            End If
        Next j
    Next i

'Select random rows up to lShowRowsPerUser for each user from the grouped results array
    For j = LBound(aUserRows, 1) To UBound(aUserRows, 1)
        Do
            Randomize
            lRandIndex = Int(Rnd() * aUserRows(j, 2, 1)) + 1
            If Not rShow Is Nothing Then
                Set rShow = Union(rShow, ws.Cells(aUserRows(j, 3, lRandIndex), sUserCol))
            Else
                Set rShow = ws.Cells(aUserRows(j, 3, lRandIndex), sUserCol)
            End If
        Loop While rShow.Cells.Count < j * Application.Min(lShowRowsPerUser, aUserRows(j, 2, 1))
    Next j
    rData.EntireRow.Hidden = True
    rShow.EntireRow.Hidden = False

'Format table
    'Sort by Opened By
        LastRow = Cells(Rows.Count, "A").End(xlUp).Row
        Worksheets("Audit Tickets").Sort.SortFields.Add Key:=Range("D1"), SortOn:=xlSortOnValues, Order:=xlAscending
        With Worksheets("Audit Tickets").Sort
            .SetRange Range("A2:G" & LastRow)
            .Orientation = xlTopToBottom
            .Apply
        End With
    'Widen columns
        Range("A:B,G:G").ColumnWidth = 15
        Columns("C:D").ColumnWidth = 18
        Columns("E:E").ColumnWidth = 50
        Columns("F:F").ColumnWidth = 22
    'Wrap text
        Range("E1:E" & LastRow).WrapText = True

End Sub

Upvotes: 0

Views: 2067

Answers (2)

QHarr
QHarr

Reputation: 84465

Far more efficient, assuming aData holds all the data and the first column is tickets, is to simply process only the two of interest with the following.

Change 1 in aData(i, 1) to whichever column holds the items of interest in the array.

For i = LBound(aData, 1) To UBound(aData, 1)
    If aData(i, 1) = "INC" Or aData(i, 1) = "SCTASK" Then   
        For j = LBound(aUserRows, 1) To UBound(aUserRows, 1)
   ''other code
    End If
Next i

Upvotes: 1

sunsetsurf
sunsetsurf

Reputation: 592

You could use advanced filter:

    Sheets("Emps").Range("A1:D8").AdvancedFilter Action:=xlFilterCopy, _
    CriteriaRange:=Sheets("Emps").Range("F5:F6"), CopyToRange:=Range("A1:B1"), _
    Unique:=False

Data to selectively copy:
enter image description here

Data copied:
enter image description here

Reference this short YouTube video; You can record a marco to help yourself with the code also:
https://www.youtube.com/watch?v=bGUKjXmEi2E

A more thorough tutorial is found here:
http://www.contextures.com/xladvfilter01.html

This tutorial shows how to get the source data from outside Excel:
https://www.extendoffice.com/documents/excel/4189-excel-dynamic-filter-to-new-sheet.html

This tutorial shows how to split data values based on a column to different sheets (Fruit column; Apple sheet, Pear sheet, etc.):
https://www.extendoffice.com/documents/excel/2884-excel-save-filtered-data-new-sheet-workbook.html

Upvotes: 0

Related Questions