Question

我有一大堆票证，共有6个不同的用户名。我需要代码做的是每个用户随机选择3行数据（共18行）并隐藏其余行，因为我只需要查看所选行。

代码将如下所示，但我不确定如何编写“随机”部分。

LastRow = Cells(Rows.Count, "A").End(xlUp).Row
With Range("A2:F" & LastRow)
*Select 3 random rows for user A*
*Select 3 random rows for user B*
*The same for C-F*

*Hide all other rows*
End With

Answer 1

发现这是一个有趣的挑战。这样的事情对你有用。为清晰起见，注释代码。

Sub tgr()

    'Adjust these parameters as necessary
    Const sDataSheet As String = "Sheet1"
    Const sUserCol As String = "A"
    Const lHeaderRow As Long = 1
    Const lShowRowsPerUser As Long = 3
    Const bSortDataByUser As Boolean = False

    'Declare variables
    Dim ws As Worksheet
    Dim rData As Range
    Dim rShow As Range
    Dim aData() As Variant
    Dim aUserRows() As Variant
    Dim lTotalUnqUsers As Long
    Dim lMaxUserRows As Long
    Dim i As Long, j As Long, k As Long
    Dim lRandIndex As Long

    'Test if sDataSheet name provided exists in ActiveWorkbook
    On Error Resume Next
    Set ws = ActiveWorkbook.Sheets(sDataSheet)
    On Error GoTo 0
    If ws Is Nothing Then
        MsgBox "No sheet named [" & sDataSheet & "] found in " & ActiveWorkbook.Name & Chr(10) & _
               "Correct sDataSheet in code and try again."
        Exit Sub
    End If
    ws.Cells.EntireRow.Hidden = False   'Reset rows to show all data

    'Work with the data range set by parameters
    With ws.Range(sUserCol & lHeaderRow + 1, ws.Cells(ws.Rows.Count, sUserCol).End(xlUp))
        'Verify data exists in specified location
        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) & "&""""))")   'Get total unique users
        lMaxUserRows = Evaluate("max(countif(" & .Address(external:=True) & "," & .Address(external:=True) & "))")  'Get max rows per user
        If bSortDataByUser Then .Sort .Cells, xlAscending, Header:=xlNo 'If bSortByUser is set to True, then sort the data
        Set rData = .Cells  'Store the data in a range object for later use
        aData = .Value  'Load the data into an array to speed operations
        ReDim aUserRows(1 To lTotalUnqUsers, 1 To 3, 1 To lMaxUserRows) 'Ready the results array that random rows will be selected from
    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     'Find correct user
                If IsEmpty(aUserRows(j, 1, 1)) Then aUserRows(j, 1, 1) = aData(i, 1)    'If user isn't in results array yet, add it
                k = aUserRows(j, 2, 1) + 1              'Increment row counter for this user
                aUserRows(j, 2, 1) = k
                aUserRows(j, 3, k) = i + lHeaderRow     'Load this row into this user's group of rows
                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   'Hide all relevant rows
    rShow.EntireRow.Hidden = False  'Only show the rows that have been randomly selected

End Sub

Excel VBA - 每个用户名随机选择3行

1 个答案: