如何修改Excel VBA随机选择宏，避免重复选中同一行？

Hey there! I see you're building a macro for your audit team to randomly select unique rows (using column B as the unique identifier), but the current code is letting duplicates slip through. Let's fix that up and make it more reliable for your team.

First, let's break down the issues in your original code #

• It checks for duplicate row numbers instead of the actual unique values in column B, which doesn't align with your requirement.
• The random row generation logic can produce non-integer values, and the loop structure might fail to collect enough rows if it hits duplicates repeatedly.
• It uses Activate which can lead to unexpected behavior if users have other sheets open.

Here's the revised macro that fixes these problems #

This version uses a dictionary to track already selected column B values, ensures proper randomization, adds validation, and avoids messy sheet activation:

Option Explicit
Option Base 1

Sub Random_Sel_Unique()
    Dim wsData As Worksheet, wsOutput As Worksheet
    Dim lastRow As Long, numRowsToSelect As Long
    Dim selectedIDs As Object ' Tracks unique column B values
    Dim randomRow As Long
    Dim currentID As String
    
    ' Set worksheet references (no more Activate/Select!)
    Set wsData = ThisWorkbook.Sheets("DATA")
    Set wsOutput = ThisWorkbook.Sheets("Sheet2")
    Set selectedIDs = CreateObject("Scripting.Dictionary")
    
    ' Clear old results in Sheet2 first
    wsOutput.Cells.Clear
    
    ' Get the number of rows to pull from MACRO!E6
    numRowsToSelect = ThisWorkbook.Sheets("MACRO").Range("E6").Value
    
    ' Validate the input is within your 5-25 range
    If numRowsToSelect < 5 Or numRowsToSelect > 25 Then
        MsgBox "Please enter a number between 5 and 25 in MACRO!E6.", vbExclamation
        Exit Sub
    End If
    
    lastRow = wsData.Range("A" & wsData.Rows.Count).End(xlUp).Row
    
    ' Check if there are enough unique rows to select from
    Dim uniqueCount As Long
    wsData.Range("B2:B" & lastRow).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=wsData.Range("ZZ1"), Unique:=True
    uniqueCount = wsData.Range("ZZ" & wsData.Rows.Count).End(xlUp).Row - 1
    If uniqueCount < numRowsToSelect Then
        MsgBox "Only " & uniqueCount & " unique rows exist in column B. Please adjust the number in MACRO!E6.", vbExclamation
        wsData.Range("ZZ1:ZZ" & uniqueCount + 1).Clear ' Clean up temp list
        Exit Sub
    End If
    wsData.Range("ZZ1:ZZ" & uniqueCount + 1).Clear ' Clean up temp list
    
    ' Loop until we have the required number of unique rows
    Do While selectedIDs.Count < numRowsToSelect
        ' Generate random row (skips row 1 assuming it's a header; adjust +2 if your data starts elsewhere)
        randomRow = Int((lastRow - 1) * Rnd() + 2)
        
        ' Grab the unique ID from column B
        currentID = wsData.Cells(randomRow, "B").Value
        
        ' Only copy if this ID hasn't been selected yet
        If Not selectedIDs.Exists(currentID) Then
            selectedIDs.Add currentID, randomRow
            wsData.Rows(randomRow).Copy Destination:=wsOutput.Cells(selectedIDs.Count, "A")
        End If
    Loop
    
    MsgBox numRowsToSelect & " unique rows copied to Sheet2 successfully!", vbInformation
End Sub

Key improvements explained #

• Dictionary for unique tracking: This ensures we never pick the same column B value twice, which is exactly what you need.
• Input validation: Prevents invalid numbers in E6 and checks if there are enough unique rows to avoid infinite loops.
• No more Activate/Select: Using direct worksheet references makes the macro more stable and faster.
• Clean slate for results: Wipes Sheet2 before adding new selections so old data doesn't mix in.
• Proper randomization: The Int((lastRow - 1) * Rnd() + 2) line ensures we only pick rows from your data range (adjust the +2 if your data starts at row 1 instead of row 2).

Quick note on the dictionary #

If you get an error about the dictionary, you can either:

1. Go to Tools > References in the VBA editor and check "Microsoft Scripting Runtime", or
2. Keep using the late-binding method in the code (CreateObject("Scripting.Dictionary")) which works without enabling the reference.

内容的提问来源于stack exchange，提问作者Mass Nerderer