如何根据Excel中的条件随机select行数？

我想从一张纸上随机select50行，并将其粘贴到单独的工作簿中进行数据采样。 我不知道该怎么做，因为首先，我是VBA的新手，我想学习新的东西，然后尝试在Google上search，但没有find准确的答案。

那么我的想法是：

1. 我将首先获取该工作表中的行数。 我已经完成了这一行代码：
   CountRows = ActiveSheet.Cells(ActiveSheet.Rows.Count, "A").End(xlUp).Row

2. 获取从1到CountRows一个随机数。 随机数应该是增量的（1,5,7,20,28,30,50而不是反向计数）。 然后抓住那一行，创build一个新的工作簿，如果尚未打开并粘贴在那里。

我怎样才能实现这个过程？ 我不知道如何开始这个。

Answer 1

以下代码将做你所需要的。

 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 

以上代码使用字典，因此您必须添加对Microsoft脚本运行时types库的引用。 在Visual Basic编辑器中，转到工具 – >引用，并在列表中选中“Microsoft脚本运行时” 。

如果有什么不清楚，请告诉我。

Answer 2

首先，使用此例程在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 

现在你可以使用上面的例程生成随机的，唯一的和sorting的索引，并复制相应的行。 这是一个例子：

 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