选择随机行并复制到其他工作表

Question

下面的宏随机选择一行并复制到不同的工作表。如何让宏随机选择多行并复制到不同的工作表？

Sub CopyRandom()

    Sheets("Sheet13").Select
    Range("A15:I50").Select
    Selection.Clear
    
    Sheets("GB-151").Select
    
    Dim PopulationSelect As Range
    Set PopulationSelect = Range("A9:A346")
    Dim nLastRow As Long
    Dim nFirstRow As Long
    Set r = PopulationSelect

    nLastRow = r.Rows.Count + r.Row - 14
    nFirstRow = r.Row
    n = Application.WorksheetFunction.RandBetween(nFirstRow, nLastRow)
    Cells(n, 1).EntireRow.Select
    
    Selection.Copy

    Sheets("Sheet13").Select
    Range("A15").Select
    ActiveSheet.Paste

End Sub

按预期复制了一个随机行，但无法复制多个随机行。

Answer 1

这是一种方法：

Sub CopyRandomRows()
    Dim rngSrc As Range, rngDest As Range, i As Long
    Dim col As New Collection, n As Long
    
    Set rngSrc = ThisWorkbook.Worksheets("GB-151").Range("A9:I346") 'source range
    Set rngDest = ThisWorkbook.Worksheets("Sheet13").Range("A15")   'first paste range
    rngDest.Resize(45, 9).Clear                    'clear any previous data from paste area
    
    For i = 1 To rngSrc.Rows.Count 'fill collection with potential row numbers
        col.Add i
    Next i
    
    Application.ScreenUpdating = False
    For n = 1 To 20 'pick(eg) 20 random rows
        i = Application.WorksheetFunction.RandBetween(1, col.Count) 'random item from collection
        With rngSrc.Rows(col.item(i)) 'the selected row...
            rngDest.Resize(1, .Columns.Count).Value = .Value 'copy chosen row (A:I)
        End With
        col.Remove i  'remove the selected index from the collection to prevent re-selection
        Set rngDest = rngDest.Offset(1) 'next paste position
    Next n
End Sub