VBA/Macro 获取具有多个条件的随机数据

Question

我需要帮助才能从具有特定条件的另一个工作表中获取随机数据

类似这样的：

如果我单击一个按钮或运行一个宏，我应该从rawdata.xlsx "Sheet1" 工作表中获取4 random samples for all rows that has AA、1 random sample for all rows that has BB、1 random sample for all rows that has CC、3 random samples for all rows that has DD 和1 random sample for all rows that has EE 并将其粘贴到tool.xlsm "Random Sample" 工作表中。

一切都应该一键完成。

到目前为止，这是我的代码。我只能在整个工作表中获得特定数量的随机数据。我希望有人可以为我编辑此代码或提供代码来帮助我并能够做出我想做的事情。提前致谢

Sub CopyRandomRows()


    Sheets("Random Sample").Select
       Cells.Select
       Range("C14").Activate
       Selection.Delete Shift:=xlUp


 Windows("rawdata.xlsx").Activate
    Rows("1:1").Select
    Selection.Copy
    Application.CutCopyMode = False
    Selection.Copy
    Windows("tool.xlsm").Activate
    Sheets("Random Sample").Select
    Rows("1:1").Select
    ActiveSheet.Paste

  Dim source As Range, target As Range, randCount&, data(), value, r&, rr&, c&

  'this defines the source to take the data
  Set source = Workbooks("rawdata.xlsx").Worksheets("Sheet1").Range("A2:L5215")

  'this defines the target to paste the data
  Set target = Workbooks("tool.xlsm").Worksheets("Random Sample").Range("A2")

  'this defines the number of rows to generate based on the input in textbox
  randCount = 20
  'this loads the data in an array
  data = source.value

  'this shuffles the rows
  For r = 1 To randCount
    rr = 1 + Math.Round(VBA.rnd * (UBound(data) - 1))
    For c = 1 To UBound(data, 2)
      value = data(r, c)
      data(r, c) = data(rr, c)
      data(rr, c) = value
    Next
  Next

  'this writes the data to the target
  target.Resize(randCount, UBound(data, 2)) = data


End Sub

Answer 1

我会这样做：

Option Explicit

'******************************************************
'*** needs reference to Microsoft Scripting Runtime ***
'******************************************************
Sub GetRandomSamples()
Dim oDicSam As Dictionary
Dim iCounter As Integer, k As Variant, iRandom As Integer, iRndMin As Integer, iRndMax As Integer, j As Integer
Dim source As Worksheet, target As Worksheet

On Error GoTo Err_GetRandomSamples

Set source = ThisWorkbook.Worksheets(1)
Set target = ThisWorkbook.Worksheets(2)

'define the range for randomizing
iRndMin = 1
iRndMax = 500

'define the numbers of records for each column    
Set oDicSam = New Dictionary
oDicSam.Add "AA", 4
oDicSam.Add "BB", 1
oDicSam.Add "CC", 1
oDicSam.Add "DD", 3
oDicSam.Add "EE", 1

j = 1
Randomize
For Each k In oDicSam.Keys
    For iCounter = 1 To oDicSam.Item(k)
        iRandom = Int((iRndMax - iRndMin + 1) * Rnd + iRndMin)
        'MsgBox "Random number for '" & k & "' is: " & iRandom, vbInformation, "Randomizing - " & iCounter
        source.Range(k & iRandom).Copy target.Range("A" & j)
        j = j + 1
    Next
Next

Exit_GetRandomSamples:
    On Error Resume Next
    Set source = Nothing
    Set target = Nothing
    Set oDicSam = Nothing
    Exit Sub


Err_GetRandomSamples:
    MsgBox Err.Description, vbExclamation, Err.Number
    Resume Exit_GetRandomSamples

End Sub

如您所见，我正在使用Dictionary 对象，这有助于定义要为每列获取的样本数。然后，我正在使用 thw 循环。第一个是遍历键的集合，第二个使用与该键相关的值（项）。

根据您的需要随意更改代码。