Excel VBA - 每个唯一组的 N 个随机记录

Question

我正在开发一个系统健康检查工具来验证 4 个不同的系统是否同步。为此，我需要每天为来自主数据集中的每个唯一键/组合创建一个包含随机 N 条记录的样本数据集。将从该示例数据集中检查所有 4 个系统的记录，并使用条件格式突出显示任何差异。

我无法弄清楚如何使用上述标准从主数据集中提取样本数据集。

例如，我有一个包含 700 行的报表。 6 个字段 [Client-Contractor-Distribution Center-Service Level-Alert Value-Status] 的每个唯一组合（连接以创建一个键）有 100 条记录。这部分将是动态的。每个组合可以有任意数量的唯一组合和任意数量的记录。下图供参考。此处仅显示组，因为我无法在问题中粘贴 700 条记录。有 7 个不同的组，每个组有 100 条记录。

在 cmets 中存在一些问题，我在下面给出澄清： -组合/组=基本上是通过连接焦点列创建的键，以识别/定义记录可能属于的类别。例如连接名字和姓氏以创建一个人的唯一身份。

• 所有记录都将在一张纸上。它是从系统下载的报告。
• 每个分组的记录顺序：特定组的所有记录不会被捆绑在一起。所有记录都从系统中转储到报告中。我们通过连接焦点列来创建组/键。

假设我希望 7 个 GroupKey 中的每一个都有 5 个随机记录。本质上，我需要一种方法来获取随机选择的 35 条记录，每个唯一组合 5 条。 所需输出的示例如下所示。

我尝试过使用 RAND() 和 RANDBETWEEN() 公式。我确实得到随机记录。但问题是我无法确保每个组合获得 5 条记录，有时还会返回重复记录。我愿意接受任何方法（VBA/公式）来实现这一点。

对于像我这样最多只是 VBA 新手/初学者的人来说，这是一个非常复杂的问题。

Answer 1

请测试下一个代码。它需要引用“Microsoft Scripting Runtime”：

Sub RandomRecPerGroup()
   Dim sh As Worksheet, shRet As Worksheet, lastR As Long, dict As New Scripting.Dictionary
   Dim arr, arrIt, i As Long, j As Long, f As Long, k As Long, count As Long, arrFin
   
   Set sh = ActiveSheet 'use here the sheet you need
   Set shRet = sh.Next  'use here the sheet you need (for testing reason, the next against the active one)
   shRet.Range("G1").EntireColumn.NumberFormat = "@"   'format the column to keep 'Reference number' as text
   lastR = sh.Range("A" & sh.rows.count).End(xlUp).row 'last row
   arr = sh.Range("A2:G" & lastR).Value ' place the range in an array for faster iteration
   ReDim arrFin(1 To 5, 1 To 7): k = 1  'reDim the array to keep each group
   For i = 1 To UBound(arr)             'iterate between the array elements:
        'create a dictionary key if not already existing, with the number of the row as item:
        If Not dict.Exists(arr(i, 1) & arr(i, 2) & arr(i, 3) & arr(i, 4) & arr(i, 5) & arr(i, 6)) Then
            dict.Add arr(i, 1) & arr(i, 2) & arr(i, 3) & arr(i, 4) & arr(i, 5) & arr(i, 6), i
        Else 'adding the number of row, separated by "|"
            dict(arr(i, 1) & arr(i, 2) & arr(i, 3) & arr(i, 4) & arr(i, 5) & arr(i, 6)) = _
                  dict(arr(i, 1) & arr(i, 2) & arr(i, 3) & arr(i, 4) & arr(i, 5) & arr(i, 6)) & "|" & i
        End If
   Next i
   Dim rndNo As Long              'a variable to receive the random number
   For i = 0 To dict.count - 1    'iterate between the dictionary elements:
        arrIt = Split(dict.items(i), "|"): ' split the item by "|" to obtain the same group existing rows
        For k = 1 To 5            'iterate to extract the 5 necessary sample rows of each group
                Randomize         'initialize the random numbers generation
                If UBound(arrIt) = -1 Then Exit For     'for the case of less than 5 rows per group
                rndNo = CLng(UBound(arrIt) * Rnd())     'give a value to the variable keeping the random numbers
                For f = 1 To 7                          'iterating to place in the array all 7 columns value
                    arrFin(k, f) = arr(arrIt(rndNo), f)
                Next f
                arrIt = Filter(arrIt, arrIt(rndNo), False) 'eliminate the element just placed in an array, to avoid doubling
        Next k
        lastR = shRet.Range("A" & sh.rows.count).End(xlUp).row + 1 'last empty row of the sheet where the result is returned
        shRet.Range("A" & lastR).Resize(5, 7).Value = arrFin       'drop the array content
   Next i
   MsgBox "Ready..."
End Sub

代码可能在没有提到的参考的情况下工作（使用 labe 绑定），但我认为受益于智能感知建议应该是件好事。如果创建它看起来很复杂，请（首先）运行下一个将自动添加它的代码：

Sub addScrRunTimeRef()
  'Add a reference to 'Microsoft Scripting Runtime':
  'In case of error ('Programmatic access to Visual Basic Project not trusted'):
  'Options->Trust Center->Trust Center Settings->Macro Settings->Developer Macro Settings->
  '         check "Trust access to the VBA project object model"
  On Error Resume Next
  Application.VBE.ActiveVBProject.References.AddFromFile "C:\Windows\SysWOW64\scrrun.dll"
  If err.Number = 32813 Then
        err.Clear: On Error GoTo 0
        MsgBox "The reference already exists...": Exit Sub
  Else
        On Error GoTo 0
        MsgBox """Microsoft Scripting Runtime"" reference added successfully..."
  End If
End Sub

保存工作簿将保留参考。因此，无需再次运行代码...

Answer 2

所以基本上你有 700 种可能性，你想从中得到 5 个随机值，同时你确定你没有重复？

基本上有两种方法可以做到这一点：

• 您创建了一个随机值的结果集合，您使用随机生成器生成从 1 到 700 的数字，但在将它们添加到您的集合之前，您需要验证它们是否已经存在于您的集合中。类似（伪代码）：

    Dim col_Result as Collection
    Dim finished as Boolean = False;
    Dim r as integer;
  
    while (not finished){
         r = ConvertToInt(Random(700)) + 1;
         if not(col_Result.Contains(r))
         then col_Result.Add(r);
         finished = (col_Result.Count == 5);
    }
  

• 您创建了一个从 1 到 700 的所有数字的集合，并从中检索了 5 次随机值，同时从集合中减去该值。类似的东西（又是伪代码）：

    Dim col_Values as Collection = (1, 2, ..., 700);
    Dim col_Result as Collection;
  
    Dim r as integer;
  
    for (int i = 0; i < 5; i++){
        r = ConvertToInt(Random(700));
        col_Result.Add(r);
        col_Values.Subtract(r);
    }
  

使用最后一种方法时，从集合中减去一个值会转移其他值，这一点至关重要：(1,2,3,4,5).Subtract(2) 产生(1,3,4,5)。