Macro To Copy Random Rows

DerbyDad03 June 11, 2010 at 21:16:57

re: Is there any easy way to perform this task within excel? I guess that depends on your definition of easy. ;-) This code will create an array of random row numbers. The size of the array will be equal to 20% of the number of rows that contain data in Sheet1 Column A - assuming every row in the range contains data. In other words, it doesn't count the data in Column A, it just determines the last row that contains data. It then loops through the array using the Random numbers as Row numbers to determine which rows to copy to Sheet2. Please make sure you test this in a backup copy of your workbook as macro's can not be undone. Option Explicit Sub Random20() Randomize 'Initialize Random number seed Dim MyRows() As Integer ' Declare dynamic array. Dim numRows, percRows, nxtRow, nxtRnd, chkRnd, copyRow As Integer 'Determine Number of Rows in Sheet1 Column A numRows = Sheets(1).Range("A" & Rows.Count).End(xlUp).Row 'Get 20% of that number percRows = numRows * 0.2 'Allocate elements in Array ReDim MyRows(percRows) 'Create Random numbers and fill array For nxtRow = 1 To percRows getNew: 'Generate Random number nxtRnd = Int((numRows) * Rnd + 1) 'Loop through array, checking for Duplicates For chkRnd = 1 To nxtRow 'Get new number if Duplicate is found If MyRows(chkRnd) = nxtRnd Then GoTo getNew Next 'Add element if Random number is unique MyRows(nxtRow) = nxtRnd Next 'Loop through Array, copying rows to Sheet2 For copyRow = 1 To percRows Sheets(1).Rows(MyRows(copyRow)).EntireRow.Copy _ Destination:=Sheets(2).Cells(copyRow, 1) Next End Sub

Thank you so much! Worked perfect!!

DerbyDad03 June 14, 2010 at 07:07:26

Glad I could help.