如何使excel随机选择器不选择两次相同的事物？

时间：2019-05-09 13:11:00

标签： excel vba

我正在使用从其他来源使用的一些代码，并根据需要对其进行了调整。唯一的问题是，我现在想知道是否可以使它不会两次选择同一行？ E6的值将始终在5到25之间，并且将从500多行中提取。我只想确保提取的数据不相同。这是出于审核目的，而另一个团队几乎没有卓越经验。这就是为什么我将其设为宏。

我已经尝试了一些尝试，但是我想我不知道如何正确实现它，否则它根本无法正常工作。 

Option Explicit
Option Base 1

Sub Random_Sel()

Dim LastRow As Long
Dim NbRows As Long
Dim RowList()
Dim I As Long, J As Long, K As Long
Dim RowNb As Long
    Sheets("DATA").Activate
    LastRow = Range("A" & Rows.Count).End(xlUp).Row
    NbRows = Sheets("MACRO").Range("E6").Value
    ReDim RowList(1 To NbRows)
    K = 1
    For I = 1 To NbRows
        RowNb = Rnd() * LastRow
        For J = 1 To K
            If (RowList(J) = RowNb) Then GoTo NextStep
        Next J
        RowList(K) = RowNb
        Rows(RowNb).Copy Destination:=Sheets("Sheet2").Cells(K, "A")
        K = K + 1
NextStep:
    Next I
End Sub

预期结果将是不会重复Sheet2上的数据。 B列是我的唯一标识符所在的位置，以确定它是否重复。

4 个答案:

答案 0 :(得分：2)

您需要跟踪是否已检查该行。

但是，首先，我们需要创建一个函数来检查元素是否在数组中

  

由Check if a value is in an array or not with Excel VBA的@Brad提供 

Public Function IsInArray(number As Integer, arr As Variant) As Boolean
    Dim i
    For i = LBound(arr) To UBound(arr)
        If arr(i) = number Then
            IsInArray = True
            Exit Function
        End If
    Next i
    IsInArray = False

End Function

因此，在循环之前，您需要声明一个数组。

Dim checkedrows() As Integer
Dim counter as Integer: counter = 0 ' to keep track of Re-Dim

并在循环内，假设您要检查的值在RowNb内

If Not IsInArray(RowNb, checkedrows) Then ' was not checked yet
   ' do something (your code)... and then:
   counter = counter + 1
   ReDim Preserve checkedrows(counter)
   checkedrows(counter) = RowNb ' adds the row to the  checkedrows array
End If

答案 1 :(得分：0)

@Rawrplus那么它需要看起来像这样吗？当我以这种方式编译时，我得到了ByRef参数类型不匹配错误。 

Option Explicit
Option Base 1
Public Function IsInArray(number As Integer, arr As Variant) As Boolean
    Dim i
    For i = LBound(arr) To UBound(arr)
        If arr(i) = number Then
            IsInArray = True
            Exit Function
        End If
    Next i
    IsInArray = False

End Function
Sub Random_Sel()

Dim checkedrows() As Integer
Dim counter As Integer: counter = 0
Dim LastRow As Long
Dim NbRows As Long
Dim RowList()
Dim i As Long, J As Long, K As Long
Dim RowNb As Long

If Not IsInArray(RowNb, checkedrows) Then
    Sheets("DATA").Activate
    LastRow = Range("A" & Rows.Count).End(xlUp).Row
    NbRows = Sheets("MACRO").Range("E6").Value
    ReDim RowList(1 To NbRows)
    K = 1
    For i = 1 To NbRows
        RowNb = Rnd() * LastRow
        For J = 1 To K
            If (RowList(J) = RowNb) Then GoTo NextStep
        Next J
        RowList(K) = RowNb
        Rows(RowNb).Copy Destination:=Sheets("Sheet2").Cells(K, "A")
        K = K + 1
NextStep:
    Next i
   counter = counter + 1
   ReDim Preserve checkedrows(counter)
   checkedrows(counter) = RowNb
End If
End Sub

答案 2 :(得分：0)

这是构建唯一随机数列表的另一种方法。它基于集合的键必须唯一的事实。

它将建立一个长NumPicks的列表，其中包含MinNum和MaxNum之间的数字，如果尝试添加列表中已有的数字，则会发送错误，并且我们接下来继续。

Sub Test()
    Dim oNumbers As Collection
    'Test picking 10 numbers between 6 and 16
    Set oNumbers = RandomList(6, 16, 10)
End Sub

Public Function RandomList(ByVal MinNum As Long, ByVal MaxNum As Long, ByVal NumPicks As Long) As Collection
    Dim oRet As New Collection

    If MaxNum - MinNum < NumPicks Then
        MsgBox ("Not enough items to have unique picks")
        Exit Function
    End If

    Dim oRandom As Long
    Do Until oRet.Count = NumPicks
        On Error Resume Next
        oRandom = Int((MaxNum - MinNum + 1) * Rnd + MinNum)
        oRet.Add oRandom, CStr(oRandom)
        On Error GoTo 0
    Loop

    Set RandomList = oRet
End Function

答案 3 :(得分：0)

类似的事情应该对您有用：

Sub tgr()

    Dim wb As Workbook
    Dim wsData As Worksheet
    Dim wsMacro As Worksheet
    Dim wsDest As Worksheet

    Set wb = ThisWorkbook
    Set wsData = wb.Worksheets("DATA")
    Set wsMacro = wb.Worksheets("MACRO")
    Set wsDest = wb.Worksheets("Sheet2")

    Dim lNumResults As Long
    lNumResults = wsMacro.Range("E6").Value
    If lNumResults <= 0 Then
        MsgBox "Number of Randomly Selected results must be greater than 0", , "Error"
        Exit Sub
    End If

    Dim aResults() As Variant
    ReDim aResults(1 To lNumResults, 1 To 1)

    Dim aData As Variant
    With wsData.Range("A1", wsData.Cells(wsData.Rows.Count, "A").End(xlUp))
        If .Cells.Count = 1 Then
            ReDim aData(1 To 1)
            aData(1) = .Value
        Else
            aData = Application.Transpose(.Value)
        End If
    End With

    Dim sDelim As String
    sDelim = Chr(1)

    Dim sTemp As String
    Dim lRandom As Long
    Dim ixResult As Long
    Dim i As Long

    ixResult = 0
    For i = 1 To UBound(aResults, 1)
        Randomize
        lRandom = Int(Rnd() * UBound(aData)) + IIf(i = 1, 1, 0)
        ixResult = ixResult + 1
        aResults(ixResult, 1) = aData(lRandom)
        sTemp = Join(aData, sDelim)
        sTemp = Replace(sDelim & sTemp & sDelim, sDelim & aResults(i, 1) & sDelim, sDelim, , , vbTextCompare)
        If Len(sTemp) > Len(sDelim) Then
            sTemp = Mid(sTemp, Len(sDelim) + 1, Len(sTemp) - Len(sDelim) * 2)
            aData = Split(sTemp, sDelim)
        Else
            Exit For
        End If
    Next i

    wsDest.Columns("A").ClearContents
    wsDest.Range("A1").Resize(ixResult).Value = aResults

End Sub

编辑：此方法将从“数据”表的A列复制每个随机选择的值的整行：

Sub tgr()

    Dim wb As Workbook
    Dim wsData As Worksheet
    Dim wsMacro As Worksheet
    Dim wsDest As Worksheet

    Set wb = ThisWorkbook
    Set wsData = wb.Worksheets("DATA")
    Set wsMacro = wb.Worksheets("MACRO")
    Set wsDest = wb.Worksheets("Sheet2")

    Dim lNumResults As Long
    lNumResults = wsMacro.Range("E6").Value
    If lNumResults <= 0 Then
        MsgBox "Number of Randomly Selected results must be greater than 0", , "Error"
        Exit Sub
    End If

    Dim aData As Variant
    Dim i As Long
    With wsData.Range("A1", wsData.Cells(wsData.Rows.Count, "A").End(xlUp))
        If .Cells.Count = 1 Then
            ReDim aData(1 To 1)
            aData(1) = .Address
        Else
            ReDim aData(1 To .Cells.Count)
            Dim DataCell As Range
            i = 0
            For Each DataCell In .Cells
                i = i + 1
                aData(i) = DataCell.Address
            Next DataCell
        End If
    End With

    Dim sDelim As String
    sDelim = Chr(1)

    Dim rCopy As Range
    Dim sTemp As String
    Dim lRandom As Long

    For i = 1 To lNumResults
        Randomize
        lRandom = Int(Rnd() * UBound(aData)) + IIf(i = 1, 1, 0)
        If Not rCopy Is Nothing Then
            Set rCopy = Union(rCopy, wsData.Range(aData(lRandom)))
        Else
            Set rCopy = wsData.Range(aData(lRandom))
        End If
        sTemp = Join(aData, sDelim)
        sTemp = Replace(sDelim & sTemp & sDelim, sDelim & aData(lRandom) & sDelim, sDelim, , , vbTextCompare)
        If Len(sTemp) > Len(sDelim) Then
            sTemp = Mid(sTemp, Len(sDelim) + 1, Len(sTemp) - Len(sDelim) * 2)
            aData = Split(sTemp, sDelim)
        Else
            Exit For
        End If
    Next i

    wsDest.Cells.Clear
    If Not rCopy Is Nothing Then rCopy.EntireRow.Copy wsDest.Range("A1")

End Sub
相关问题
最新问题