如何根據Excel中的條件隨機選擇行數？

Question

我想從一張紙上隨機選擇50行，並將它們粘貼到單獨的工作簿中進行數據采樣。 我不知道該怎么做，因為首先，我是VBA的新手，我想學習新的東西，其次，我嘗試在Google上進行搜索，但找不到准確的答案。

所以我的想法是：

1. 我將首先獲得該工作表中的行數。 我已經用這一行代碼完成了：
   CountRows = ActiveSheet.Cells(ActiveSheet.Rows.Count, "A").End(xlUp).Row

2. 從1到CountRows唯一地獲得一個隨機數。 隨機數應該是遞增的（1、5、7、20、28、30、50，並且不能向后計數）。 然后抓取該行，如果尚未打開，請創建一個新工作簿並將其粘貼到那里。

我如何才能實現這一過程？ 我不知道如何開始。

Answer 1

首先，使用以下例程生成介於1和CountRows之間的50個唯一數字的數組：

' Generate a sorted array(0 to count-1) numbers between a and b inclusive
Function UniqueRandom(ByVal count As Long, ByVal a As Long, ByVal b As Long) As Long()
  Dim i As Long, j As Long, x As Long
  ReDim arr(b - a) As Long

  Randomize
  For i = 0 To b - a:    arr(i) = a + i:     Next
  If b - a < count Then UniqueRandom = arr:    Exit Function

  For i = 0 To b - a    'Now we shuffle the array
    j = Int(Rnd * (b - a))
    x = arr(i):   arr(i) = arr(j):   arr(j) = x    ' swap
  Next

  ' After shuffling the array, we can simply take the first portion
  ReDim Preserve arr(0 To count - 1)

  'sorting, probably not necessary
  For i = 0 To count - 1
    For j = i To count - 1
      If arr(j) < arr(i) Then x = arr(i):   arr(i) = arr(j):   arr(j) = x   ' swap
    Next
  Next

  UniqueRandom = arr
End Function

現在，您可以使用上面的例程來生成隨機，唯一和排序的索引並復制相應的行。 這是一個例子：

Sub RandomSamples()
  Const sampleCount As Long = 50
  Dim lastRow As Long, i As Long, ar() As Long, rngToCopy As Range

  With Sheet1
    lastRow = .Cells(.Rows.count, "A").End(xlUp).row
    ar = UniqueRandom(sampleCount, 1, lastRow)
    Set rngToCopy = .Rows(ar(0))
    For i = 1 To UBound(ar)
      Set rngToCopy = Union(rngToCopy, .Rows(ar(i)))
    Next
  End With
  With Workbooks.Add
    rngToCopy.Copy .Sheets(1).Cells(1, 1)
    .SaveAs ThisWorkbook.path & "\" & "samples.xlsx"
    .Close False
  End With
End Sub

Answer 2

以下代碼將滿足您的需求。

Sub Demo()
    Dim lng As Long
    Dim tempArr() As String
    Dim srcWB As Workbook, destWB As Workbook
    Dim rng As Range
    Dim dict As New Scripting.Dictionary
    Const rowMax As Long = 100 'maximum number of rows in source sheet
    Const rowMin As Long = 1   'starting row number to copy
    Const rowCopy As Long = 50 'number of rows to copy
    Dim intArr(1 To rowCopy) As Integer, rowArr(1 To rowCopy) As Integer
    Set srcWB = ThisWorkbook

    'get unique random numbers in dictionary
    With dict
        Do While .Count < rowCopy
            lng = Rnd * (rowMax - rowMin) + rowMin
            .Item(lng) = Empty
        Loop
        tempArr = Split(Join(.Keys, ","), ",")
    End With

    'convert random numbers to integers
    For i = 1 To rowCopy
        intArr(i) = CInt(tempArr(i - 1))
    Next i

    'sort random numbers
    For i = 1 To rowCopy
        rowArr(i) = Application.WorksheetFunction.Small(intArr, i)
        If rng Is Nothing Then
            Set rng = srcWB.Sheets("Sheet1").Rows(rowArr(i))
        Else
            Set rng = Union(rng, srcWB.Sheets("Sheet1").Rows(rowArr(i)))
        End If
    Next i

    'copy random rows, change sheet name and destination path as required
    Set destWB = Workbooks.Add
    With destWB
        rng.Copy destWB.Sheets("Sheet1").Range("A1")
        .SaveAs Filename:="D:\Book2.xls", FileFormat:=56
    End With
End Sub

上面的代碼使用了Dictionary，因此您必須添加對Microsoft腳本運行時類型庫的引用。 在Visual Basic編輯器中，轉到“ 工具”->“參考 ” ，然后在列表中檢查“ Microsoft Scripting Runtime” 。

讓我知道是否有任何不清楚的地方。