Public Function PerfectNumber(ByVal Number As Long) As Boolean
Dim laFactor() As Long
Dim lDenom As Long
Dim lCounter As Long
Dim lSum As Long
'Perfect Numbers must be even
If Number Mod 2 = 1 Then Exit Function
'Seed the array with the values 1 + 2
ReDim laFactor(0 To 1)
laFactor(0) = 1
laFactor(1) = 2
'Loop through all number fro 3 to the mid-point
For lDenom = 3 To CLng(Number / 2)
'If the number is a factor..
If Number Mod lDenom = 0 Then
'..add it to the array
ReDim Preserve laFactor(UBound(laFactor) + 1)
laFactor(UBound(laFactor)) = lDenom
End If
Next lDenom
'Sum up the factors
For lCounter = 0 To UBound(laFactor)
lSum = lSum + laFactor(lCounter)
Next lCounter
'If the sum of factors equals the number
'It is Perfect
PerfectNumber = (lSum = Number)
End Function