Sorry, I reread your first post and think I misunderstood what you were
trying to accomplish. For each option on the active sheet (reference page),
this determines how many times the same number of that value shows up on
other sheets, and calculates % match based on entries in ActiveSheet. How
about this code (careful with the line breaks):

Public Function OptionCounting(ws As Worksheet, Optional lngSearchColumn As
Long = 1) As Range
Dim rngActiveRange As Range, rngBottom As Range, rngTop As Range, rngArea
As Range
Dim varFrequencies As Variant, varTest As Variant, varTemp As Variant
Dim i As Long, j As Long, lngUBoundvarTest As Long, rngStart As Range
Dim rngFirstZero As Range, lngTempIdx As Long

If Left(ws.Name, 5) < "Sheet" Then Exit Function

With ws
Application.StatusBar = "Calculating " & ws.Name
'For every entry, how many examples are there?
varFrequencies =
Application.WorksheetFunction.Frequency(.Columns(l ngSearchColumn),
..Columns(lngSearchColumn))

Set rngTop = .Cells(1, lngSearchColumn)
If Not WorksheetFunction.IsNumber(rngTop) Then Set rngTop =
rngTop.End(xlDown)
Set rngBottom = rngTop.End(xlDown)
Set rngActiveRange = .Range(rngTop, rngBottom)

'This section deals with possible empty cells, in a sheet.
'If not an issue, the loop never happens.
Set rngTop = rngBottom.End(xlDown)
Do While rngTop.Row < 65535
Set rngBottom = rngTop.End(xlDown)
Set rngActiveRange = Union(rngActiveRange, .Range(rngTop, rngBottom))
Set rngTop = rngBottom.End(xlDown)
Loop
.Activate
rngActiveRange.Select
End With

lngTempIdx = 0 'This keeps track of where I am in varTemp, needed for
multiple areas
lngUBoundvarTest = rngActiveRange.Cells.Count
ReDim varTest(1 To lngUBoundvarTest, 1 To 2)
For Each rngArea In rngActiveRange.Areas 'If empty cells not an issue,
only iterates once
varTemp = rngArea.Value
For j = 1 To UBound(varTemp)
varTest(j + lngTempIdx, 1) = varTemp(j, 1)
varTest(j + lngTempIdx, 2) = varFrequencies(j + lngTempIdx, 1)
Next j
lngTempIdx = lngTempIdx + j - 1
Next rngArea

With ThisWorkbook.Worksheets(mcstrScratchName)
.Activate
.Cells.Clear
Set rngStart = .Range(.Cells(1, 1), .Cells(lngUBoundvarTest, 2))
rngStart.Value = varTest
rngStart.Sort Header:=xlNo, _
Key1:=.Cells(1, 2), Order1:=xlDescending, _
Key2:=.Cells(1, 1), Order2:=xlAscending
Set rngFirstZero = rngStart.Columns(2).Find(What:=0, LookIn:=xlValues,
LookAt:=xlWhole)
Set rngStart = rngStart.Resize(rngFirstZero.Row - 1, 2)
rngStart.Sort Header:=xlNo, Key1:=.Cells(1, 1), Order1:=xlAscending
End With
Application.StatusBar = Application.StatusBar & "... Completed"
Set OptionCounting = rngStart
End Function

Public Sub CompareOptions3()
Dim aws As Worksheet, ws As Worksheet
Dim varReference As Variant
Dim lngRefItems As Long, lngIdx As Long, i As Long, j As Long
Dim strMessageBox As String
Dim rngTest As Range
Dim sglNumMatches As Single

Set aws = ActiveSheet
If Left(aws.Name, 5) < "Sheet" Then
MsgBox "Worksheet name must start with 'Sheet'"
Exit Sub
End If

On Error Resume Next
strMessageBox = ThisWorkbook.Worksheets(mcstrScratchName).Name
On Error GoTo 0

If strMessageBox = "" Then
ThisWorkbook.Worksheets.Add Befo=ThisWorkbook.Sheets(1)
ThisWorkbook.Worksheets(1).Name = mcstrScratchName
End If
Application.ScreenUpdating = False

On Error Resume Next
varReference = OptionCounting(aws, 3).Value
On Error GoTo 0

If VarType(varReference) = vbEmpty Then Exit Sub

lngRefItems = UBound(varReference)
strMessageBox = "SheetName" & vbTab & "% Match"
For Each ws In aws.Parent.Worksheets
If Left(ws.Name, 5) = "Sheet" And ws.Name < aws.Name Then
sglNumMatches = 0
Set rngTest = OptionCounting(ws, 3)
For i = 1 To lngRefItems
lngIdx = 0
On Error Resume Next
lngIdx = Application.WorksheetFunction.Match(varReference(i , 1),
rngTest.Columns(1), 0)
On Error Resume Next
If lngIdx 0 Then
If rngTest.Cells(lngIdx, 2).Value = varReference(i, 2) Then
sglNumMatches = sglNumMatches + 1
End If
End If
Next i
strMessageBox = strMessageBox & vbCrLf & ws.Name & vbTab &
Format(sglNumMatches / lngRefItems, "0.00%")
End If
Next ws
On Error Resume Next
With Application
.DisplayAlerts = False
ThisWorkbook.Worksheets(mcstrScratchName).Delete
.DisplayAlerts = True
.StatusBar = False
.ScreenUpdating = True
End With
aws.Activate
MsgBox strMessageBox
End Sub