Change input range select box to a known range

Luked94

New Member
Joined
Feb 24, 2021
Messages
1
Office Version
  1. 365
Platform
  1. Windows
Hi guys!

I have the following code to generate a "lottery" for recognition at work. Each employee gets a ticket each time they gain recognition. I have a table in excel with headings of "Employee" in A1 and "Number of Recognition Votes" in B1 (see table at bottom). The code I have currently makes me select the range manually and manually select the output cell of all of the "tickets" which basically multiplies the names by the number of votes which then allows me to put them in a "virtual pot" where I select a name at random to win a prize! The more votes you have, the more likely they are to win. The full code works well however I don't want to manually select the range, i want to do this automatically.

I have the following code currently:

Dim Rng As Range
Dim InputRng As Range, OutRng As Range
xTitleId = "KutoolsforExcel"
Set InputRng = Application.Selection
Set InputRng = Application.InputBox("Range :", xTitleId, InputRng.Address, Type:=8)
Set OutRng = Application.InputBox("Out put to (single cell):", xTitleId, Type:=8)
Set OutRng = OutRng.Range("A1")
For Each Rng In InputRng.Rows
xValue = Rng.Range("A1").Value
xNum = Rng.Range("B1").Value
OutRng.Resize(xNum, 1).Value = xValue
Set OutRng = OutRng.Offset(xNum, 0)
Next


The only complication is that the code doesnt like multiplying by 0, so if there are employees with 0 recognition votes it sends an error. I have written into the code a "sort" element which sortes teh votes from largest to smallest and then people with no votes the cells are left blank. I then know what i need to happen in terms of coding but dont know how to write it.

Effectively once the data is sorted from largest to smallest, I need to find the last cell in column B with a number in it. So, selecting Cell A1 first, I use Ctr+right to get to the outer edge of the table and then Ctr+down to get to the last value with a vote in it. Once have found this cell, I need to select the range from this cell to cell A2 (as there are headings in my table)

This would then define the input range rather than having to manually input it.

I would also like to automatically select the output of this code to D2 rather than again select the output cell.

Hope you guys can help! :)

Luke

The full code is here:

Sub CopyData2()
'Updateby Extendoffice

'Sort list

Range("B1").Select
ActiveWorkbook.Worksheets("Sheet1").AutoFilter.Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Sheet1").AutoFilter.Sort.SortFields.Add2 Key:= _
Range("B1"), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:= _
xlSortNormal
With ActiveWorkbook.Worksheets("Sheet1").AutoFilter.Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With

'Make selection and generate tickets

Dim Rng As Range
Dim InputRng As Range, OutRng As Range
xTitleId = "KutoolsforExcel"
Set InputRng = Application.Selection
Set InputRng = Application.InputBox("Range :", xTitleId, InputRng.Address, Type:=8)
Set OutRng = Application.InputBox("Out put to (single cell):", xTitleId, Type:=8)
Set OutRng = OutRng.Range("A1")
For Each Rng In InputRng.Rows
xValue = Rng.Range("A1").Value
xNum = Rng.Range("B1").Value
OutRng.Resize(xNum, 1).Value = xValue
Set OutRng = OutRng.Offset(xNum, 0)
Next

'Select Random ticket


Dim HowMany As Integer
Dim NoOfNames As Long
Dim RandomNumber As Integer
Dim Names() As String 'Array to store randomly selected names
Dim i As Byte
Dim CellsOut As Long 'Variable to be used when entering names onto worksheet
Dim ArI As Byte 'Variable to increment through array indexes
Application.ScreenUpdating = False
HowMany = Range("L2").Value
CellsOut = 5
ReDim Names(1 To HowMany) 'Set the array size to how many names required
NoOfNames = Application.CountA(Range("D:D")) - 1 ' Find how many names in the list
i = 1
Do While i <= HowMany
RandomNo:
RandomNumber = Application.RandBetween(2, NoOfNames + 1)
'Check to see if the name has already been picked
For ArI = LBound(Names) To UBound(Names)
If Names(ArI) = Cells(RandomNumber, 4).Value Then
GoTo RandomNo
End If
Next ArI
Names(i) = Cells(RandomNumber, 4).Value ' Assign random name to the array
i = i + 1
Loop
'Loop through the array and enter names onto the worksheet
For ArI = LBound(Names) To UBound(Names)
Cells(CellsOut, 12) = Names(ArI)
CellsOut = CellsOut + 1
Next ArI
Application.ScreenUpdating = True

End Sub

MrExcel Loto.PNG
 

Excel Facts

Copy formula down without changing references
If you have =SUM(F2:F49) in F50; type Alt+' in F51 to copy =SUM(F2:F49) to F51, leaving the formula in edit mode. Change SUM to COUNT.

Forum statistics

Threads
1,144,615
Messages
5,725,321
Members
422,613
Latest member
salim9696

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top