Question

我有以下代码集，其中列出了故障单数据，并根据Col D中的用户名随机选择了三行。

然而，由于最近我们的票务系统发生了变化，我现在需要更新它以不选择某些票证。具体来说，我只需要选择INC和SCTASK门票，而不是RITM门票。

我不太确定如何添加过滤器，以便在此搜索中不包含票号中的RITM票证（票号在Col A中）。

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

Answer 1

假设aData保存所有数据且第一列是故障单，则效率更高，只需处理以下两个。

将1中的aData(i, 1)更改为包含数组中感兴趣项目的列。

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

Answer 2

您可以使用高级过滤器：

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

有选择地复制的数据：

复制的数据：

参考此简短的YouTube视频;您也可以记录一个marco来帮助自己代码：
https://www.youtube.com/watch?v=bGUKjXmEi2E

这里有一个更强大的详尽的教程：
http://www.contextures.com/xladvfilter01.html

本教程介绍如何从Excel外部获取源数据：
https://www.extendoffice.com/documents/excel/4189-excel-dynamic-filter-to-new-sheet.html

本教程介绍如何将基于列的数据值拆分为不同的工作表（Fruit列; Apple工作表，Pear工作表等）：
https://www.extendoffice.com/documents/excel/2884-excel-save-filtered-data-new-sheet-workbook.html

Excel VBA - 根据多个条件选择随机行

2 个答案: