MACRO RUN random percentage and copy of column values

[jctraveler]

Dear all, thanks in advance for looking at this thread..

I have found the following macro that randomly select an amount of cells based on a popup window that asks you how many cells you need to randomly getand copy the values into another column. So basically given a Column A with a series of numbers, you run the macro and you are requested to provide the number of cells you want to be copied, the macro make some calculations and works on Columns B and C and copy the values randomly in Column D.

Said that.. my question is.. would it be possible to replace the number yourequest to have a copy with a percentage request? (e.g. instead of copy 15numbers out 10000, copy the 10% or 20% or whichever% out of 10000)

Sub Macro1()
'Macro assumptions:
'Sheet1 contains random numbers in column A. May contain text or blankcells also.
'Columns B and C in Sheet1 are available for temporary use by the macro, and do not contain data
'Data will be inserted into Sheet2 in column A
Dim CountCells
Dim RandCount
Dim LastRow
Dim Counter1
Dim Counter2
Worksheets("Sheet1").Select
Range("A1").Select
CountCells = WorksheetFunction.Count(Range("A:A")) 'quantity of random numbers to pick from
If CountCells = 0 Then Exit Sub
On Error Resume Next
Application.DisplayAlerts = False
RandCount = Application.InputBox(Prompt:="How many random numbers do you want?", _
Title:="Random Numbers Selection", Type:=1)
On Error GoTo 0
Application.DisplayAlerts = True
RandCount = Int(RandCount)
If Int(RandCount) <= 0 Or RandCount = False Then Exit Sub
If RandCount > CountCells Then
MsgBox "Requested quantity of numbers is greater than quantity of available data"
Exit Sub
End If
LastRow = Cells(Rows.Count, "A").End(xlUp).Row
'clear working area
Range("B:C").ClearContents
'clear destination area
Range("D").ClearContents
'create index for sort use
Range("B1") = 1
Range(Cells(1, 2), Cells(LastRow, 2)).DataSeries , Step:=1
'create random numbers for sort
Range("C1") = "=RAND()"
Range("C1").Copy Range(Cells(1, 3), Cells(LastRow, 3))
'randomly sort data
Range(Cells(1, 1), Cells(LastRow, 3)).Sort Key1:=Range("C1"), Order1:=xlAscending, Header:=xlGuess, _
Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
'data has been sorted randomly, cells in column A, rows 1 through the quantity desired will be chosen
Counter1 = 1
Counter2 = 1
Do Until Counter1 > RandCount
If IsNumeric(Cells(Counter2, 1).Value) And Cells(Counter2, 1).Value<> Empty Then
Range("D" & Counter1) = Cells(Counter2, 1).Value
Counter1 = Counter1 + 1
End If
Counter2 = Counter2 + 1
Loop
'resort data into original order and clear working area
Range(Cells(1, 1), Cells(LastRow, 3)).Sort Key1:=Range("B1"), Order1:=xlAscending, Header:=xlGuess, _
Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
Range("B:C").ClearContents
End Sub

 

[jctraveler22]

Thanks for the support.. solution came out..

i think this will do it replace this

Code:

randcount = application.inputbox(prompt:="how many random numbers do you want?", _
title:="random numbers selection", type:=1)
on error goto 0
application.displayalerts = true
randcount = int(randcount)

with this

randcount = application.inputbox(prompt:="what % of random numbers do you want?", _
title:="random numbers selection", type:=1)
on error goto 0
application.displayalerts = true
randcount = int((randcount / 100) * application.worksheetfunction.count(range("a:a")))[code]