Priority & Ranking Assignments

[Guest]

Hi, this could use soem polishing up to give it a little
more flexibility but here is a good start.

I set up a spreadsheet as follows:

Name1,2,... in cells b3 thru f3 (allowed)
with exp, pri1,pri2, and pri3 in rows 4 thru 7

items in cells b9 thru g9 (allowed)
with rank in row 10

Items to be assigned in b13 thru e13
with rank in row 14 via hlookup(b13,b9:f10,2,false)
and row 15 left blank for assigning names

ranges with counts of names, items, and toassign

John

Given all that, this seemed to work:

Sub Macro1()
'
' Macro1 Macro
'
' Names,Items, Toassign are the counts of # Names, #
Items, and
' # of Items to assign to someone
'
Dim Names As Integer
Dim Items As Integer
Dim Toassign As Integer
Dim ID(25) As String
Dim Exp(25) As Integer
Dim Pri1(25) As String
Dim Pri2(25) As String
Dim Pri3(25) As String
Dim Item(25) As String
Dim Rank(25) As Integer
Dim IDassign(25) As String
'Sort Names by Experience
'
Range("B3:G7").Select
Selection.Sort Key1:=Range("B4"),
Order1:=xlDescending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False,
Orientation:=xlLeftToRight
'
'Sort Items by Rank
'
Range("B9:G10").Select
Selection.Sort Key1:=Range("B10"),
Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False,
Orientation:=xlLeftToRight
'
' Read in Names Count and Items Count
'
Names = Range("Names").Value
Items = Range("Items").Value
Toassign = Range("toassign").Value
'
' Read in Information
'
For i = 1 To Names
ID(i) = Cells(3, i + 1).Value
Exp(i) = Cells(4, i + 1).Value
Pri1(i) = Cells(5, i + 1).Value
Pri2(i) = Cells(6, i + 1).Value
Pri2(i) = Cells(7, i + 1).Value
Next i
For i = 1 To Toassign
Item(i) = Cells(13, i + 1).Value
Rank(i) = Cells(14, i + 1).Value
Next i
'
'Search items for a match under ID's
'
For i = 1 To Toassign
For j = 1 To Names
'Check and see if Name(j) still available
If ID(j) = NA Then GoTo nextj
If Item(i) = Pri1(j) Then GoTo found
nextj:
Next j
For j = 1 To Names
'Check and see if Name(j) still available
If ID(j) = NA Then GoTo nextj2
If Item(i) = Pri2(j) Then GoTo found
nextj2:
Next j
For j = 1 To Names
'Check and see if Name(j) still available
If ID(j) = NA Then GoTo nextj3
If Item(i) = Pri3(j) Then GoTo found
nextj3:
Next j
GoTo nexti
found:
IDassign(i) = ID(j)
'Change Name of assigned name to NA
ID(j) = NA
'Change Name of assigned Item to Assigned
Item(i) = Assigned
nexti:
Next i
'If item not found, assign highest ranked item to most
'experienced person available
For i = 1 To Items
' Check to see if item assigned
If Item(i) = Assigned Then GoTo nexti2
For j = 1 To Names
' Check and see if name available
If ID(j) = NA Then GoTo nextj4
'Assign Name to item i
IDassign(i) = ID(j)
'Change Name of assigned name to NA
ID(j) = NA
'Change Name of assigned Item to Assigned
Item(i) = Assigned
GoTo nexti2
nextj4:
Next j
nexti2:
If j = Names Then GoTo allassigned
Next i
allassigned:
' Check to see if any Items not assigned, and if so ID
' them as "Unassigned"
For i = 1 To Toassign
If Item(i) = Assigned Then GoTo nexti3
IDassign(i) = "Unassigned"
nexti3:
Next i
For i = 1 To Toassign
Cells(15, i + 1).Value = IDassign(i)
Next i
End Sub

 

[Guest]

Note that the 2nd read in of Pri2 should be pri3 - copied
too quickly - i tested some other scenarios and found that
error.


John