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
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
