Macro to select Random

Question

Hi,

I have a workbook that has 1000+ rows and 26 columns

In column “M” I have user codes (e.g. abc2002).

I need a macro to pull 10% random based on column “M” and insert entire rows in Sheet2 (With the header included).

I have another identical workbook (Pre_Random.xls) that has all the previous months random

My other condition for the 10% random is that I don’t want any user code to match the user codes in (Pre_Random.xls)

For example the macro should not pick “zye1232” because it is already in  (Pre_Random.xls).

Thank you

Answer 1

The worksheet with the data did not have 26 columns, only filled to column U, so I changed

With .Range(.Range("AA2"), .Cells(.Rows.Count, "Z").End(xlUp)(1, 2))

to

With .Range("AA2:AA" & .Usedrange.Rows.Count)

On reflection, I should have probably started with that or

With .Range("AA2:AA" & .Cells(.Rows.Count, "M").End(xlUp).Row)

Answer 2

You did not mention that you could have duplicated values in column M.  Try this version:

Sub ExportRandom10Percent()

Dim wkbkPR As Workbook

Dim strSN As String

ThisWorkbook.Save

On Error GoTo OpenPR

Set wkbkPR = Workbooks("Pre_Random.xls")

On Error GoTo 0

GoTo AlreadyOpen

OpenPR:

Set wkbkPR = Workbooks.Open(ThisWorkbook.Path & "\Pre_Random.xls")

AlreadyOpen:

strSN = wkbkPR.Sheets(1).Name

ThisWorkbook.Sheets(1).Copy After:=ThisWorkbook.Sheets(1)

With ThisWorkbook.Sheets(2)

.Range("AA1").Value = "Sort"

With .Range(.Range("AA2"), .Cells(.Rows.Count, "Z").End(xlUp)(1, 2))

.FormulaR1C1 = "=IF(COUNTIF(R1C13:RC[-14],RC[-14])=1,IF(ISERROR(MATCH(RC[-14],'[Pre_Random.xls]" & strSN & "'!C13,FALSE)),RAND(),10),10)"

.Value = .Value

End With

.Cells.Sort .Range("AA2"), xlAscending, header:=xlYes

.Range("AA1").Offset(1 + .UsedRange.Rows.Count / 10).Resize(.UsedRange.Rows.Count).EntireRow.Delete

.Range("AA:AA").Delete

wkbkPR.SaveCopyAs ThisWorkbook.Path & "\Pre_Random_" & Format(Date, "yyyy-mm") & ".xls"

wkbkPR.Close False

Application.DisplayAlerts = False

.Copy

ActiveWorkbook.SaveAs ThisWorkbook.Path & "\Pre_Random.xls"

End With

End Sub

Answer 3

It is giving me a lot of duplicates. All other steps are okay.

Answer 4

Assuming that AA is actually a blank column, and that all columns A to Z are fully populated, with headers in row 1.  The code will create a new Pre_Random.xls and save the previous version with a date stamp.

Sub ExportRandom10Percent()

Dim wkbkPR As Workbook

ThisWorkbook.Save

On Error GoTo OpenPR

Set wkbkPR = Workbooks("Pre_Random.xls")

On Error GoTo 0

GoTo AlreadyOpen

OpenPR:

Set wkbkPR = Workbooks.Open(ThisWorkbook.Path & "\Pre_Random.xls")

AlreadyOpen:

ThisWorkbook.Sheets(1).Copy After:=ThisWorkbook.Sheets(1)

With ThisWorkbook.Sheets(2)

.Name = "Random"

.Range("AA1").Value = "Sort"

With .Range(.Range("AA2"), .Cells(.Rows.Count, "Z").End(xlUp)(1, 2))

.FormulaR1C1 = "=IF(ISERROR(MATCH(RC[-14],[Pre_Random.xls]Sheet1!C13,FALSE)),RAND(),10)"

.Value = .Value

End With

.Cells.Sort .Range("AA2"), xlAscending, header:=xlYes

.Range("AA1").Offset(1 + .UsedRange.Rows.Count / 10).Resize(.UsedRange.Rows.Count).EntireRow.Delete

.Range("AA:AA").Delete

wkbkPR.SaveCopyAs ThisWorkbook.Path & "\Pre_Random_" & Format(Date, "yyyy-mm") & ".xls"

wkbkPR.Close False

Application.DisplayAlerts = False

.Copy

ActiveWorkbook.SaveAs ThisWorkbook.Path & "\Pre_Random.xls"

End With

End Sub