Question

我想从一张表中随机选择50行，然后将它们粘贴到单独的工作簿中进行数据采样。我不知道该怎么做，因为首先，我是VBA的新手，我想学习新的东西，其次，我尝试在Google上搜索这个，但没有找到准确的答案。

所以我的想法是：

我首先获得该工作表中的行数。我已经用这一行代码完成它：
CountRows = ActiveSheet.Cells(ActiveSheet.Rows.Count, "A").End(xlUp).Row
唯一地从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 Scripting Runtime Type Library的引用。在Visual Basic编辑器中，转到 工具 - >参考 并在列表中选中 “Microsoft Scripting Runtime”

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

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

2 个答案: