Here's what I've got now that I threw in a couple of lines to take care of a few cases where the distribution is symmetrical.

Function FisherExact(r As Range)

Dim i As Long, p() As Double, s As Double, n As Long, x(1 To 2, 1 To 2) As Double, y(1 To 2, 1 To 2) As Double

Dim a As Double, b As Double, c As Double, d As Double, BaseProb As Double

If r.Rows.Count <> 2 Or r.Columns.Count <> 2 Then

FisherExact = "#Inputnot2x2"

Exit Function

End If

n = Application.Min(r)

ReDim p(0 To n)

'put smallest value in x(1,1)

If r(1, 1) = n Then

x(1, 1) = r(1, 1)

x(2, 1) = r(2, 1)

x(1, 2) = r(1, 2)

x(2, 2) = r(2, 2)

ElseIf r(1, 2) = n Then

x(1, 1) = r(1, 2)

x(2, 1) = r(2, 2)

x(1, 2) = r(1, 1)

x(2, 2) = r(2, 1)

ElseIf r(2, 1) = n Then

x(1, 1) = r(2, 1)

x(2, 1) = r(1, 1)

x(1, 2) = r(2, 2)

x(2, 2) = r(1, 2)

Else

x(1, 1) = r(2, 2)

x(2, 2) = r(1, 1)

x(1, 2) = r(1, 2)

x(2, 1) = r(2, 1)

End If

a = x(1, 1) + x(1, 2) + 1

b = x(2, 1) + x(2, 2) + 1

c = x(1, 1) + x(2, 1) + 1

d = x(1, 2) + x(2, 2) + 1

'calculate observed table probability

With Application

p(0) = Exp(.GammaLn(a) - .GammaLn(x(1, 1) + 1) + .GammaLn(b) - .GammaLn(x(1, 2) + 1) + .GammaLn(c) - .GammaLn(x(2, 1) + 1) + .GammaLn(d) - .GammaLn(x(2, 2) + 1) - .GammaLn(a + b - 1))

End With

BaseProb = p(0)

s = p(0)

'store table for second tail calculation

y(1, 1) = x(2, 1)

y(1, 2) = x(2, 2)

y(2, 1) = x(1, 1)

y(2, 2) = x(1, 2)

'calculate more extreme table probabilities

For i = 1 To n

p(i) = p(i - 1) * x(1, 1) * x(2, 2)

x(1, 1) = x(1, 1) - 1

x(1, 2) = x(1, 2) + 1

x(2, 1) = x(2, 1) + 1

x(2, 2) = x(2, 2) - 1

p(i) = p(i) / (x(2, 1) * x(1, 2))

'only add if probability is less than observed table

If p(i) < p(0) Then

s = s + p(i)

End If

Next i

If y(1, 1) + y(1, 2) = y(2, 1) + y(2, 2) Or y(1, 1) + y(2, 1) = y(1, 2) + y(2, 2) Then

FisherExact = 2 * s

GoTo Ending

End If

'calculate second tail using same method

If y(1, 1) > y(2, 2) Then

n = y(2, 2)

Else

n = y(1, 1)

End If

ReDim p(0 To n)

p(0) = BaseProb

For i = 1 To n

p(i) = p(i - 1) * y(1, 1) * y(2, 2)

y(1, 1) = y(1, 1) - 1

y(1, 2) = y(1, 2) + 1

y(2, 1) = y(2, 1) + 1

y(2, 2) = y(2, 2) - 1

p(i) = p(i) / (y(2, 1) * y(1, 2))

If p(i) < p(0) Then

s = s + p(i)

End If

Next i

FisherExact = s

Ending:

End Function