Fatal编程技术网
  • excel/
  • 如何使excel随机选择器不重复选择同一事物？

如何使excel随机选择器不重复选择同一事物？

excel vba

如何使excel随机选择器不重复选择同一事物？,excel,vba,Excel,Vba,我正在使用从另一个源代码中使用的一些代码，并根据自己的需要对其进行了调整。唯一的一件事，我现在想知道我是否可以使它不会选择同一行两次？E6的值始终在5到25之间，这将从500多行中提取。我只是想确保提取的数据是不同的。这是为了审计另一个几乎没有excel经验的团队。这就是为什么我要把它变成一个宏 我用谷歌搜索了一些东西来尝试，但我想我不知道如何正确地实现它，或者它根本不起作用 Option Explicit Option Base 1 Sub Random_Sel() Dim LastRow

我正在使用从另一个源代码中使用的一些代码，并根据自己的需要对其进行了调整。唯一的一件事，我现在想知道我是否可以使它不会选择同一行两次？E6的值始终在5到25之间，这将从500多行中提取。我只是想确保提取的数据是不同的。这是为了审计另一个几乎没有excel经验的团队。这就是为什么我要把它变成一个宏

我用谷歌搜索了一些东西来尝试，但我想我不知道如何正确地实现它，或者它根本不起作用

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
预期结果是表2中的数据不会重复。列B是唯一标识符所在的位置，用于确定该行是否重复。

您需要跟踪该行是否已被选中

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

由@Brad提供，来自

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

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
您需要跟踪行是否已检查

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

由@Brad提供，来自

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

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
@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
@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
这里有一种不同的方法来构建唯一随机数列表。它基于这样一个事实：收藏的密钥必须是唯一的

它将建立一个列表
NumPicks
long，其中的数字介于
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

子测试（）
作为集合的Dim oNumbers
'测试选择6到16之间的10个数字
Set oNumbers=RandomList（6,16,10）
端接头
作为集合的公共函数随机列表（ByVal MinNum为Long，ByVal MaxNum为Long，ByVal NumPicks为Long）
Dim oRet作为新系列
如果MaxNum-MinNum
这里有一种不同的方法来构建唯一随机数列表。它基于这样一个事实：收藏的密钥必须是唯一的

它将建立一个列表
NumPicks
long，其中的数字介于
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

子测试（）
作为集合的Dim oNumbers
'测试选择6到16之间的10个数字
Set oNumbers=RandomList（6,16,10）
端接头
作为集合的公共函数随机列表（ByVal MinNum为Long，ByVal MaxNum为Long，ByVal NumPicks为Long）
Dim oRet作为新系列
如果MaxNum-MinNum
像这样的东西应该适合你：

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

Sub-tgr（）
将wb设置为工作簿
将wsData设置为工作表
将wsMacro设置为工作表
将wsDest设置为工作表
设置wb=ThisWorkbook
设置wsData=wb.工作表（“数据”）
设置wsMacro=wb.工作表（“宏”）
设置wsDest=wb.工作表（“表2”）
暗淡的lNumResults尽可能长
lNumResults=wsMacro.Range（“E6”）.值
如果lNumResults Len（sDelim），则
sTemp=Mid（sTemp，Len（sDelim）+1，Len（sTemp）-Len（sDelim）*2）
aData=拆分（sTemp、sDelim）
其他的
退出
如果结束
接下来我
wsDest.Columns（“A”）.ClearContents
wsDest.Range（“A1”）.Resize（ixResult）.Value=aResults
端接头
编辑：此方法将复制“数据”表A列中每个随机选择值的整行：

Sub-tgr（）
将wb设置为工作簿
将wsData设置为工作表
将wsMacro设置为工作表
将wsDest设置为工作表
设置wb=ThisWorkbook
设置wsData=wb.工作表（“数据”）
设置wsMacro=wb.工作表（“宏”）
设置wsDest=wb.工作表（“表2”）
暗淡的lNumResults尽可能长
lNumResults=wsMacro.Range（“E6”）.值
如果lNumResults Len（sDelim），则
sTemp=Mid（sTemp，Len（sDelim）+1，Len（sTemp）-Len（sDelim）*2）
aData=拆分（sTemp、sDelim）
其他的
退出
如果结束
接下来我
wsDest.Cells.Clear
如果不是rCopy，则rCopy.EntireRow.Copy wsDest.Range（“A1”）为空
端接头
像这样的东西应该适合你：

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

Sub-tgr（）
将wb设置为工作簿
将wsData设置为工作表
将wsMacro设置为工作表
将wsDest设置为工作表
设置wb=ThisWorkbook
设置wsData=wb.工作表（“数据”）
设置wsMacro=wb.工作表（“宏”）
设置wsDest=wb.工作表（“表2”）
暗淡的lNumResults尽可能长
lNumResults=wsMacro.Range（“E6”）.值
如果lNumResults Len（sDelim），则
sTemp=Mid（sTemp，Len（sDelim）+1，Len（sTemp）-Len（sDelim）*2）
aData=拆分（sTemp、sDelim）
其他的
退出
如果结束
接下来我
wsDest.Columns（“A”）.ClearContents
W