Friday, September 9, 2011

Macro for Support Functions

The following functions are used by the primary functions on this page.
Private Function ArrayElementsInOrder(Arr As Variant, _
    Optional Descending As Boolean = False, _
    Optional Diff As Integer = 0) As Boolean
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' ArrayElementsInOrder
' This function tests an array of integers (Long or Int) to determine
' if they are in order, in ascending or descending sort order, and
' optionally if they all differ by exactly Diff. Diff is the absolute
' value between two adjacent elements. Do not use a negative number
' for a descending sort; Diff should always be greater than 0 to test
' the differences or 0 to ignore differences. The default behavior
' is to test whether the elements are in ascending order with any
' difference between them. Set the Descending and/or Diff parameters
' to change this.
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim N As Long
For N = LBound(Arr) To UBound(Arr) - 1
    If Descending = False Then
        If Diff > 0 Then
            If Arr(N) <> Arr(N + 1) - Diff Then
                ArrayElementsInOrder = False
                Exit Function
            End If
        Else
            If Arr(N) > Arr(N + 1) Then
                ArrayElementsInOrder = False
                Exit Function
            End If
        End If
    Else
        If Diff > 0 Then
            If Arr(N) <> Arr(N + 1) + Diff Then
                ArrayElementsInOrder = False
                Exit Function
            End If
        Else
            If Arr(N) < Arr(N + 1) Then
                ArrayElementsInOrder = False
                Exit Function
            End If
        End If
    End If
Next N
ArrayElementsInOrder = True
End Function



Private Function TestFirstLastSort(FirstToSort As Long, LastToSort As Long, _
    ByRef ErrorText As String) As Boolean
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' TestFirstLastSort
' This ensures FirstToSort and LastToSort are valid values. If successful,
' returns True and sets ErrorText to vbNullString. If unsuccessful, returns
' False and set ErrorText to the reason for failure.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
ErrorText = vbNullString
If FirstToSort <= 0 Then
    TestFirstLastSort = False
    ErrorText = "FirstToSort is less than or equal to 0."
    Exit Function
End If

If FirstToSort > Worksheets.Count Then
    TestFirstLastSort = False
    ErrorText = "FirstToSort is greater than number of sheets."
    Exit Function
End If

If LastToSort <= 0 Then
    TestFirstLastSort = False
    ErrorText = "LastToSort is less than or equal to 0."
    Exit Function
End If

If LastToSort > Worksheets.Count Then
    TestFirstLastSort = False
    ErrorText = "LastToSort greater than number of sheets."
    Exit Function
End If

If FirstToSort > LastToSort Then
    TestFirstLastSort = False
    ErrorText = "FirstToSort is greater than LastToSort."
    Exit Function
End If
    
TestFirstLastSort = True

End Function


Private Function IsArrayAllocated(Arr As Variant) As Boolean
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' IsArrayAllocated
' Returns True or False indicating if Arr is an allocated
' array.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    On Error Resume Next
    Dim V As Variant
    IsArrayAllocated = True
    V = Arr(LBound(Arr, 1))
    If IsError(V) = True Then
        IsArrayAllocated = False
    End If
    If (UBound(Arr, 1) < LBound(Arr, 1)) Then
        IsArrayAllocated = False
    End If
    
End Function

Private Function SheetExists(WSName As String, Optional WB As Workbook = Nothing) As Boolean
''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' SheetExists
' Returns True if worksheet named by WSName exists in
' Workbook WB. If WB is omitted,
' the ActiveWorkbook is used.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''
On Error Resume Next
SheetExists = IsError(IIf(WB Is Nothing, ActiveWorkbook, WB).Worksheets(WSName)) = False

End Function

No comments:

Post a Comment