Excel decisionmaker

[Fer9us]

Hi MrExcel,

I'm trying to use excel to help me to create a tool to make complex decisions -- to find favourite items or options among a single list of multiple items or options.
This should be relatively simple to program, only I am a newbie at this.

I would really appreciate suggestions on how to code this process:

1. User inputs a number of items/options into LIST A.

2. Excel calculates the number of entries in LIST A and the number of combinations of pairs entries (without any repeats/duplicates).

3. Excel then generates a 2-COLUMN TABLE showing all the possible different pair combinations from the original list.

4. Entries from the 2-COLUMN TABLE are fed into a QUESTIONNAIRE (row by row), using a template "Which option from this pair is preferable? A or B?"

5. The user completes the QUESTIONNAIRE, and the votes for each individual item/option are tallied.

6. The item/option with the most votes wins, and the winning entry is displayed, followed by the runner up, 3rd place, 4th place and so on until all entries on LIST A have been put into order of preference.

END.

Note, ideally the program/code is scalable -- so could be used to for a list of up to "N" entries.

Look forward to hearing your ideas,

Fer9us

 

[rpaulson]

Try this on a fresh worksheet

Enter you list of option in cells A2 down to A whatever.
run this macro to create all possible pairs in Columns C and D

Sub Create_Pairs()

wr = 2

For r = 2 To Cells(Rows.Count, "A").End(xlUp).Row
For rr = r + 1 To Cells(Rows.Count, "A").End(xlUp).Row

Cells(wr, "C") = Cells(r, "A")
Cells(wr, "D") = Cells(rr, "A")

wr = wr + 1
Next
Next

End Sub

now run the code below:
it will prompt you to pick which one of the items you prefer.
if will tabulate a score for each item in column "B"

Sub Add_Scores()

For wr = 2 To Cells(Rows.Count, "C").End(xlUp).Row

10 s = Application.InputBox("1 for  " & Cells(wr, "C") & vbCr & "2 for  " & Cells(wr, "D"), "Enter a value")

Select Case s
Case Is = False
Exit Sub

Case Is = 1
r = WorksheetFunction.Match(Cells(wr, "C"), Range("A:A"), 0)
Cells(r, "B") = Cells(r, "B") + 1

Case Is = 2
r = WorksheetFunction.Match(Cells(wr, "D"), Range("A:A"), 0)
Cells(r, "B") = Cells(r, "B") + 1

Case Else
GoTo 10

End Select
Next wr

End Sub

enjoy,

Ross

 

[Fer9us]

BRILLIANT! Really, thank you @rpaulson for taking the time to do this - it's already going to save me mountains of time.

Below is my example of the prioritised list.

There's a couple of things to refine this further.

1. I've added shortcut buttons on the main spreadsheet to run the VBA scripts - and they work :D

2. Could we please combine the two scripts? - i.e. Where Excel creates a list of all the pairs in the background -- so all the user needs to do is list their options, and then click the "Choose/Vote" button?

3. In the questionnaire stage, could we create two buttons labelled with the two options on each "ballot" rather than a text field?
- The user could vote either by pressing one of the labelled buttons, or pressing "1" or "2" (ideally to reduce the need for clicking "OK" following the vote -- saving time and energy).
I would do this myself if I knew how but I'm afraid to stuff up the coding/programming you've already done.

4. A final tally, showing the votes in order of preference/priority would also be excellent. I noticed in my first trials, several of my options received equal votes.

5. The above issue presents another challenge. Tied votes could be resolved with runoff rounds/tiebreakers. After the initial voting round, Excel would check if any of the options received the same number of votes starting with the options that received the highest votes (i.e. equal first, equal second and so on) and prompt the user to vote again between those pairs only (*if any of the options chose to challenge the matter in court that's another matter :P~ ).
If there's three or more options that have received equal votes, tiebreakers would need to create separate lists of possible pairs and prompt users again to choose between those options.

This process should not affect the tally of votes which should remain equal to the total number of possible pair combinations.

Once the highest-ranked ties are broken, Excel would need to check the list again for more ties and again prompt the user to choose between any tied options.

This process would repeat until the list no longer has any ties.

There could be scenarios where second, third and subsequent tiebreakers are needed until all the options are prioritised.

In the case below I did this manually.

Thanks again for looking at this and for the solutions already provided.
Look forward to hearing your thoughts,

Fer9us

 

[Fer9us]

* A further thought on the tiebreaker mentioned in point 5 above, to avoid having a ballooning number of total votes, which is higher than the total number of option pair combinations, the result of each vote could be recorded on the right of the list of pairs.

Any tiebreaker round votes would essentially recast votes for any tied options and alter that result on the list of pairs.

i.e. if ants and humans both get 6 votes, but the user really deep down likes ants more than humans, a tiebreaker would prompt the user to choose between ants and humans so that the final tally would be Humans 5 vs Ants 7.

If there's three or more options that have received equal votes, however, tiebreakers would need to create separate lists of possible pairs and prompt users again to choose between those options and the results recorded in the original list of pairs and tallied.

i.e. if it's ants 6, dogs 6, cats 6,
the recast would be to select between:
Ants vs Dogs (Dogs win +1/Ants lose -1)
Ants vs Cats (Ants win +1/Cats lose -1)
Cats vs Dogs (Dogs win +1/Cats lose -1)
The resulting tally could shift the vote to Cats 4, Dogs 8, Ants 6.

This process should not affect the total number of votes which should remain equal to the total number of possible pair combinations.

 

[rpaulson]

I am now intrigued by this little project.
I went ahead and created a user form so the user has the ability to pick the selection with a mouse click.
I also moved the picking list to a sheet called "Calc" and hide it.

let me know what you think.
Also currently no tie breaker method has been implemented.

Excel File here

Ross

 

[Fer9us]

Thanks again for working on this @rpaulson, I need to be cautious about downloading files to my computer.
Is there a way you could perhaps share code instead of a file?
Fer9us

 

[rpaulson]

Create a blank sheet and name is Calc

create a user form
add 3 things to the user form. CommandButton1, CommandButton2, and a label. Name the label "Num" no quotes

right click on userform - view code. paste the following code in.

Private Sub UserForm_Initialize()

Create_Pairs

Dim ws As Worksheet
Set ws = Worksheets("Calc")

CommandButton1.Caption = ws.[A1]
CommandButton2.Caption = ws.[B1]

num = 1 'counter

End Sub

Private Sub Create_Pairs()

Dim ws As Worksheet
Set ws = Worksheets("Calc")
ws.Cells.ClearContents

Range("B2:B50000").ClearContents 'remove old scores

wr = 1

For r = 2 To Cells(Rows.Count, "A").End(xlUp).Row
For rr = r + 1 To Cells(Rows.Count, "A").End(xlUp).Row

ws.Cells(wr, "A") = Cells(r, "A")
ws.Cells(wr, "B") = Cells(rr, "A")

wr = wr + 1
Next
Next

End Sub

Private Sub CommandButton1_Click()
Score (CommandButton1.Caption)
End Sub
Private Sub CommandButton2_Click()
Score (CommandButton2.Caption)
End Sub

Private Sub Score(item)

Dim ws As Worksheet
Set ws = Worksheets("Calc")

r = WorksheetFunction.Match(item, Range("A:A"), 0)
Cells(r, "B") = Cells(r, "B") + 1

num = num + 1
CommandButton1.Caption = ws.Cells(num, "A")
CommandButton2.Caption = ws.Cells(num, "B")


If CommandButton1.Caption = "" Then 'survey complete
MsgBox "Survey complete"
Unload UserForm1

lr = Cells(Rows.Count, "A").End(xlUp).Row
Range("A1:B" & lr).Sort Key1:=Range("B1"), Header:=xlYes, Order1:=xlDescending
End If

End Sub

add button to you main sheet to open the useform


enjoy,
Ross

 

[Fer9us]

OK trying this --

I've created a new tab labled "Calc" and added the userform in the developer screeen.

I have added the two buttons and a label.

I have pasted the code:

Now I've tried to put a new button on the main screen to launch the Userform we created, but it's not seeming to work for me.

Not sure I'm doing this right.

Any pointers? The button isn't working for me yet.

Thanks again,

Fer9us

 

[rpaulson]

does the form open?

I see you Have a line that says
Private_Sub Userform_Click ()
try deleting that line.

 

[Fer9us]

Alas no.
I've removed that line of code from the userform, but still no joy when I roll over the new button it's not linking to anything it appears.

Here's the full code I now have in the userform pane:

Private Sub Label1_Click()

End Sub

Private Sub UserForm_Initialize()

Create_Pairs

Dim ws As Worksheet
Set ws = Worksheets("Calc")

CommandButton1.Caption = ws.[A1]
CommandButton2.Caption = ws.[B1]

num = 1 'counter

End Sub

Private Sub Create_Pairs()

Dim ws As Worksheet
Set ws = Worksheets("Calc")
ws.Cells.ClearContents

Range("B2:B50000").ClearContents 'remove old scores

wr = 1

For r = 2 To Cells(Rows.Count, "A").End(xlUp).Row
For rr = r + 1 To Cells(Rows.Count, "A").End(xlUp).Row

ws.Cells(wr, "A") = Cells(r, "A")
ws.Cells(wr, "B") = Cells(rr, "A")

wr = wr + 1
Next
Next

End Sub

Private Sub CommandButton1_Click()
Score (CommandButton1.Caption)
End Sub
Private Sub CommandButton2_Click()
Score (CommandButton2.Caption)
End Sub

Private Sub Score(item)

Dim ws As Worksheet
Set ws = Worksheets("Calc")

r = WorksheetFunction.Match(item, Range("A:A"), 0)
Cells(r, "B") = Cells(r, "B") + 1

num = num + 1
CommandButton1.Caption = ws.Cells(num, "A")
CommandButton2.Caption = ws.Cells(num, "B")


If CommandButton1.Caption = "" Then 'survey complete
MsgBox "Survey complete"
Unload UserForm1

lr = Cells(Rows.Count, "A").End(xlUp).Row
Range("A1:B" & lr).Sort Key1:=Range("B1"), Header:=xlYes, Order1:=xlDescending
End If

End Sub

-----------------------------------------------------------

Thanks again,

Fer9us