Fixing the Variance Percentage Program

Okay, the previous VBA function has a few flaws: it doesn’t test for empty cells, and it is rather inefficient when it comes to memory; it stores the results in an array.

For reference, here is the original code:

Public Function LowestCompPer(vRg As Range) As Double
    Dim n As Integer
    Dim t As Integer
    Dim p() As Double
    Dim i As Integer
    Dim wsf As WorksheetFunction
    Dim j As Integer
    Dim k As Integer
    Set wsf = Excel.WorksheetFunction
    n = vRg.Count
    t = (n * (n - 1)) / 2
    ReDim p(t) As Double
    k = 1
    For i = 1 To n - 1
        For j = i + 1 To n
            p(k) = Abs(vRg(i) - vRg(j)) / (wsf.Max(Abs(vRg(i)), Abs(vRg(j))))
            k = k + 1
        Next j
    Next i
    Dim min As Integer
    min = 1
    For i = 1 To t
        If p(i) < p(min) Then
            min = i
        End If
    Next i
    LowestCompPer = p(min)
End Function

Now we’re going to fix this.  Here we go:

Public Function LowestCompPer(vRg As Range) As Double
    Dim i As Integer
    Dim j As Integer
    Dim k As Integer
    Dim FullCells As New Collection
    Dim PerDbl As Double
    Dim min As Double
    'get a count of how many cells aren't empty
    'also keep a collection of cells that aren't empty
    'This will kill two birds with one stone: it will allow us
    'us to get rid of the triangular number calculation,
    'as well as make sure that all cells we're referring to
    'actually have values in them.
    For i = 1 To vRg.Count
        If vRg(i) <> "" Then
            FullCells.Add vRg(i)
        End If
        
    Next i
    'k keeps track of whether or not the first minimum has been calculation.
    '0=no,  1=yes
    k = 0
    For i = 1 To FullCells.Count - 1
        For j = i + 1 To FullCells.Count
            'PerDbl temporarily stores the results of our comparison formula
            PerDbl = Abs(FullCells(i) - FullCells(j)) / _
                (Application.WorksheetFunction.Max(Abs(FullCells(i)), _
                Abs(FullCells(j))))
            'We have to start somewhere.  Remember, all percentages will be 
            'positive
            'Since min always start at 0, we have to initialize min
            'Once we've done that, though, we don't want to change it 
            'again unless we've found a smaller number
            If k = 0 Then
                min = PerDbl
                k = 1
            ElseIf PerDbl < min Then
                min = PerDbl
            End If
        Next j
    Next i
    'Never forget to clean up!
    Set FullCells = Nothing
    LowestCompPer = min
End Function

It may seem strange, but it works.  It may seem like we have traded one inefficiency (looping twice) with another (storing full cells in a Collection), but this was necessary to make sure that the entire range is full.

Leave any comments or questions you may have below.