Macro To Copy Random Rows

December 15, 2017 at 13:49:16
Specs: Windows 7
Hello,

I am using Macro To Copy Random Rows from one sheet to another.

Just I need to set up additional check for duplicity.
In my dataset in column C I have a user name. Random selection should never choose the row with same user name several times.

Is it possible to adjust this code with this duplicity check?

Private Sub CommandButton21_Click()

Randomize 'Initialize Random number seed customer
Dim MyRows() As Long ' Declare dynamic array.
Dim numRows, percRows, nxtRnd, copyRow As Integer
Dim chkRnd, nxtRow As Integer

'Determine Number of Rows in Sheet1 Column A
numRows = Sheets(6).Range("A" & Rows.Count).End(xlUp).Row
'Get 10 of that number
percRows = 10
'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 + 10)
'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(6).Rows(MyRows(copyRow)).EntireRow.Copy _
Destination:=Sheets(12).Range("A2:A11")(copyRow, 1)
Next

Randomize 'Initialize Random number seed pricing
Dim MyRows1() As Long ' Declare dynamic array.
Dim numRows1, percRows1, nxtRow1, nxtRnd1, chkRnd1, copyRow1 As Integer
'Determine Number of Rows in Sheet1 Column A
numRows1 = Sheets(10).Range("A" & Rows.Count).End(xlUp).Row
'Get 10 of that number
percRows1 = 10
'Allocate elements in Array
ReDim MyRows1(percRows1)
'Create Random numbers and fill array
For nxtRow1 = 1 To percRows1
getNew1:
'Generate Random number
nxtRnd1 = Int((numRows1) * Rnd + 1000)
'Loop through array, checking for Duplicates
For chkRnd1 = 1 To nxtRow1
'Get new number if Duplicate is found
If MyRows1(chkRnd1) = nxtRnd1 Then GoTo getNew1
Next
'Add element if Random number is unique
MyRows1(nxtRow1) = nxtRnd1
Next
'Loop through Array, copying rows to Sheet2
For copyRow1 = 1 To percRows1
Sheets(10).Rows(MyRows1(copyRow1)).EntireRow.Copy _
Destination:=Sheets(12).Range("A15:A24")(copyRow1, 1)
Next

Randomize 'Initialize Random number seed rebates
Dim MyRows2() As Long ' Declare dynamic array.
Dim numRows2, percRows2, nxtRow2, nxtRnd2, chkRnd2, copyRow2 As Integer
'Determine Number of Rows in Sheet1 Column A
numRows2 = Sheets(8).Range("A" & Rows.Count).End(xlUp).Row
'Get 10 of that number
percRows2 = 10
'Allocate elements in Array
ReDim MyRows2(percRows2)
'Create Random numbers and fill array
For nxtRow2 = 1 To percRows2
getNew2:
'Generate Random number
nxtRnd2 = Int((numRows2) * Rnd + 1000)
'Loop through array, checking for Duplicates
For chkRnd2 = 1 To nxtRow2
'Get new number if Duplicate is found
If MyRows2(chkRnd2) = nxtRnd2 Then GoTo getNew2
Next
'Add element if Random number is unique
MyRows2(nxtRow2) = nxtRnd2
Next
'Loop through Array, copying rows to Sheet2
For copyRow2 = 1 To percRows2
Sheets(8).Rows(MyRows2(copyRow2)).EntireRow.Copy _
Destination:=Sheets(12).Range("A27:A36")(copyRow2, 1)

Next
Dim DateAndTimeStamp As Double
Dim UserName As String

DateAndTimeStamp = Now
Sheets(12).Range("B40").Value = DateAndTimeStamp

UserName = Environ("UserName")
Sheets(12).Range("B39").Value = UserName

'Step 1: Protect the sheet with a password
Sheets(12).Protect Password:="RED"
'Step 2: Save the workbook
ActiveWorkbook.Save

End Sub


Thanks
Romana


See More: Macro To Copy Random Rows

Reply ↓  Report •

#1
December 15, 2017 at 15:30:06
Please click on the How-To link at the end of this post and read the instructions on how to post VBA code in this forum. Then repost your code so that the indents are retained thereby making it is easier for us to read.

Thanks!

How To Post Data or Code ---> Click Here Before Posting Data or VBA Code


Reply ↓  Report •

#2
December 16, 2017 at 01:14:41
Here is the code, I used one from your previous suggestions.
But still I need some additional duplicity check.

My data consist of information about changes from SAP done by user.
My random sample should not have changes done by same user twice.
Is it possible to adjust this code?

Thank you

Private Sub CommandButton21_Click()
Randomize 'Initialize Random number seed customer
Dim MyRows() As Long    ' Declare dynamic array.
Dim numRows, percRows, nxtRnd, copyRow As Integer
Dim chkRnd, nxtRow As Integer

'Determine Number of Rows in Sheet1 Column A
  numRows = Sheets(6).Range("A" & Rows.Count).End(xlUp).Row
'Get 10 of that number
   percRows = 10
'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 + 10)
'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(6).Rows(MyRows(copyRow)).EntireRow.Copy _
     Destination:=Sheets(12).Range("A2:A11")(copyRow, 1)
Next
Randomize 'Initialize Random number seed pricing
Dim MyRows1() As Long   ' Declare dynamic array.
Dim numRows1, percRows1, nxtRow1, nxtRnd1, chkRnd1, copyRow1 As Integer
'Determine Number of Rows in Sheet1 Column A
  numRows1 = Sheets(10).Range("A" & Rows.Count).End(xlUp).Row
'Get 10 of that number
   percRows1 = 10
'Allocate elements in Array
    ReDim MyRows1(percRows1)
'Create Random numbers and fill array
     For nxtRow1 = 1 To percRows1
getNew1:
'Generate Random number
      nxtRnd1 = Int((numRows1) * Rnd + 1000)
'Loop through array, checking for Duplicates
       For chkRnd1 = 1 To nxtRow1
'Get new number if Duplicate is found
        If MyRows1(chkRnd1) = nxtRnd1 Then GoTo getNew1
       Next
'Add element if Random number is unique
      MyRows1(nxtRow1) = nxtRnd1
     Next
'Loop through Array, copying rows to Sheet2
  For copyRow1 = 1 To percRows1
   Sheets(10).Rows(MyRows1(copyRow1)).EntireRow.Copy _
     Destination:=Sheets(12).Range("A15:A24")(copyRow1, 1)
Next
Randomize 'Initialize Random number seed rebates
Dim MyRows2() As Long    ' Declare dynamic array.
Dim numRows2, percRows2, nxtRow2, nxtRnd2, chkRnd2, copyRow2 As Integer
'Determine Number of Rows in Sheet1 Column A
  numRows2 = Sheets(8).Range("A" & Rows.Count).End(xlUp).Row
'Get 10 of that number
   percRows2 = 10
'Allocate elements in Array
    ReDim MyRows2(percRows2)
'Create Random numbers and fill array
     For nxtRow2 = 1 To percRows2
getNew2:
'Generate Random number
      nxtRnd2 = Int((numRows2) * Rnd + 1000)
'Loop through array, checking for Duplicates
       For chkRnd2 = 1 To nxtRow2
'Get new number if Duplicate is found
        If MyRows2(chkRnd2) = nxtRnd2 Then GoTo getNew2
       Next
'Add element if Random number is unique
      MyRows2(nxtRow2) = nxtRnd2
     Next
'Loop through Array, copying rows to Sheet2
  For copyRow2 = 1 To percRows2
   Sheets(8).Rows(MyRows2(copyRow2)).EntireRow.Copy _
     Destination:=Sheets(12).Range("A27:A36")(copyRow2, 1)
     
Next
Dim DateAndTimeStamp As Double
Dim UserName As String

DateAndTimeStamp = Now
Sheets(12).Range("B40").Value = DateAndTimeStamp

UserName = Environ("UserName")
Sheets(12).Range("B39").Value = UserName

'Step 1: Protect the sheet with a password
     Sheets(12).Protect Password:="RED"
'Step 2: Save the workbook
     ActiveWorkbook.Save

End Sub

message edited by Romi009


Reply ↓  Report •

#3
December 16, 2017 at 06:26:57
I'm am going to busy for the next couple of days so finding time to write code is going to be hit or miss. That said, I don't know your level of VBA expertise, so for now I'm going to offer a concept and if you know how to write the code to implement it, you should be all set. I may be able to check in every now then and answer questions, but actual coding will be harder to find time for. I have to set up a test sheet, try various options, etc. I just don't have time for that right now.

Maybe this will work...

The code currently checks for duplicate Row numbers by creating a random number and then looping through the partial array of Row numbers looking for a duplicate. Other than determining the 10% value, it's not looking at the sheet during this process, it's just building a list of numbers until it hits that 10%. If it creates a duplicate number, it tosses it and tries again. Once the array of unique numbers is built, it then goes back to sheet and copies those rows.

So, let's say the code does it's thing and finds the next unique random number. It could now go back to sheet and capture the name that is in that Row. It could build an array of names and then loop through that array looking for a duplicate. If doesn't find a duplicate it adds the name to name array and adds the Row number to the Row number array. If it does find a duplicate, it tosses the Row number and tries again.

The name array is only being built to help determine if the random Row number is for a Row that contains a name that has already been found. Once an array of Row numbers has been built, the name array serves no purpose. The code would still use the Row number array to copy the Rows.

I hope that makes sense.

How To Post Data or Code ---> Click Here Before Posting Data or VBA Code


Reply ↓  Report •
Related Solutions


Ask Question