Excel decisionmaker

Fer9us

New Member
Joined
Nov 28, 2020
Messages
10
Office Version
  1. 365
Platform
  1. Windows
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
 

Some videos you may like

Excel Facts

Get help while writing formula
Click the italics "fx" icon to the left of the formula bar to open the Functions Arguments dialog. Help is displayed for each argument.

rpaulson

Well-known Member
Joined
Oct 4, 2007
Messages
1,158
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

VBA Code:
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"

VBA Code:
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
 
Solution

Fer9us

New Member
Joined
Nov 28, 2020
Messages
10
Office Version
  1. 365
Platform
  1. Windows
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

1606651080676.png


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.

1606649852457.png


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.

1606649521190.png


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

Fer9us
 

Fer9us

New Member
Joined
Nov 28, 2020
Messages
10
Office Version
  1. 365
Platform
  1. Windows
* 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

Well-known Member
Joined
Oct 4, 2007
Messages
1,158

ADVERTISEMENT

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

New Member
Joined
Nov 28, 2020
Messages
10
Office Version
  1. 365
Platform
  1. Windows
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

Well-known Member
Joined
Oct 4, 2007
Messages
1,158

ADVERTISEMENT

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.

VBA Code:
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

New Member
Joined
Nov 28, 2020
Messages
10
Office Version
  1. 365
Platform
  1. Windows
OK trying this --

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

1606770428908.png

I have added the two buttons and a label.

1606770498214.png


I have pasted the code:

1606770616781.png


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.

1606771744021.png


Not sure I'm doing this right.

1606771548477.png


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

Thanks again,

Fer9us
 

rpaulson

Well-known Member
Joined
Oct 4, 2007
Messages
1,158
does the form open?

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

Fer9us

New Member
Joined
Nov 28, 2020
Messages
10
Office Version
  1. 365
Platform
  1. Windows
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.

1606813901741.png


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
 

Watch MrExcel Video

Forum statistics

Threads
1,127,123
Messages
5,622,870
Members
415,935
Latest member
kes1973

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