Support on a creative problem above my skill level

[expertlypaul]

Hi folks,

I'm interested in creating a tool where an individual could enter a list of 100 words/phrases and play a comparison game where item 1 is compared to item 2 and the user selects which item they prefer. Then, item 1 compared to item 3, and so on until all comparisons are made. At the end, I would want them to see the score for each item, listed in order with the most selected item at the top and the least selected at the bottom.

As an additional wrinkle, I would like all comparisons to be ignored if a particular item is repeatedly losing. For instance, let's say item 1 loses to items 2-20. I would like all comparisons of item 1 to items 21-100 to be skipped as the user is only going to need the top 10 winners.

How would you think through this problem?

Kindly,
Paul

 

[lrobbo314]

How about this?

Excel
	A	B	C	D	E	F
1	Colors			Red	1	<--- Result
2	Red			Blue	3
3	Green			Yellow	2
4	Blue
5	Yellow
Sheet2

Sub CompareWords()
Dim r As Range:         Set r = Range("A2:A" & Range("A" & Rows.Count).End(xlUp).Row)
Dim SD As Object:       Set SD = CreateObject("Scripting.Dictionary")
Dim Loss As Integer:    Loss = 0
Dim Tmp As String
Dim tCell As Range, cCell As Range

For i = 1 To r.Cells.Count - 1
    Set tCell = r.Cells(i, 1)
    Loss = 0
    For j = i + 1 To r.Cells.Count
        If i <> j Then
            If Loss < 20 Then
                Set cCell = r.Cells(j, 1)
                r.Cells.Interior.ColorIndex = -4142
                tCell.Interior.ColorIndex = 4
                cCell.Interior.ColorIndex = 6
                Tmp = Pick(tCell, cCell)
                If Tmp <> tCell.Text Then Loss = Loss + 1
                SD(Tmp) = SD(Tmp) + 1
            End If
        End If
    Next j
Next i

With Range("D1").Resize(SD.Count)
    .Value = Application.Transpose(SD.keys)
    .Offset(, 1).Value = Application.Transpose(SD.items)
End With
r.Interior.ColorIndex = -4142
End Sub

Function Pick(target As Range, comp As Range)
If MsgBox("Do you like " & target.Text & " over " & comp.Text, vbYesNo) = vbYes Then
    Pick = target.Text
Else
    Pick = comp.Text
End If
End Function