Macro To Copy Random Rows

Microsoft Office excel 2007 home & stude...
June 11, 2010 at 12:35:47
Specs: Windows XP
I have a spreadsheet containing several rows of data (can be over 1000 rows). First task is to randomly select 20% of the records for analysis. Of the 20% randomly selected records I need to cut and paste the entire row of data into a new tab. Is there any easy way to perform this task within excel?

See More: Macro To Copy Random Rows

Report •

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
'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
'Add element if Random number is unique
      MyRows(nxtRow) = nxtRnd
'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)
End Sub

Report •

June 14, 2010 at 06:57:50
Thank you so much! Worked perfect!!

Report •

June 14, 2010 at 07:07:26
Glad I could help.

Report •

Related Solutions

Ask Question