Some Useful Worksheet Functions-Custom functions

Returning Cell Formatting Information

Function ISBOLD(cell) As Boolean

      ISBOLD = cell.Range("A1").Font.Bold

End Function

Displaying the Date When a File was Saved or Printed

Function LASTSAVED()

      Application.Volatile

      LASTSAVED = ThisWorkbook. _

        BuiltinDocumentProperties("Last Save Time")

End Function 

Function LastSaved2()

      Application.Volatile

      LastSaved2 = Application.Caller.Parent.Parent. _

        BuiltinDocumentProperties("Last Save Time")

End Function

Understanding Object Parents

Function AppName(ref) As String

      AppName = ref.Parent.Parent.Parent.Name

End Function

Counting Cells between Two Values

Function COUNTBETWEEN(InRange, num1, num2) As Long

'     Counts number of values between num1 and num2

      With Application.WorksheetFunction

          If num1 <= num2 Then

              COUNTBETWEEN = .CountIf(InRange, ">=" & num1) - _

                .CountIf(InRange, ">" & num2)

          Else

              COUNTBETWEEN = .CountIf(InRange, ">=" & num2) - _

                .CountIf(InRange, ">" & num1)

          End If

      End With

End Function

Counting Visible Cells in a Range

Function COUNTVISIBLE(rng)

'     Counts visible cells

      Dim CellCount As Long

      Dim cell As Range

      Application.Volatile

      CellCount = 0

     Set rng = Intersect(rng.Parent.UsedRange, rng)

      For Each cell In rng

         If Not IsEmpty(cell) Then

            If Not cell.EntireRow.Hidden And _

               Not cell.EntireColumn.Hidden Then _

               CellCount = CellCount + 1

          End If

      Next cell

      COUNTVISIBLE = CellCount

End Function

Determining the Last Nonempty Cell in a Column or Row

Returns the last value in column B:

=LASTINCOLUMN(B5)

Returns the last value in row 7:

=LASTINROW(C7:D9) 

THE LASTINCOLUMN FUNCTION

Function LASTINCOLUMN(rng As Range)

'     Returns the contents of the last non-empty cell in a column

      Dim LastCell As Range

      Application.Volatile

      With rng.Parent

          With .Cells(.Rows.Count, rng.Column)

              If Not IsEmpty(.Value) Then

                  LASTINCOLUMN = .Value

              ElseIf IsEmpty(.End(xlUp)) Then

                  LASTINCOLUMN = ""

              Else

                  LASTINCOLUMN = .End(xlUp).Value

              End If

           End With

      End With

End Function

THE LASTINROW FUNCTION

Function LASTINROW(rng As Range)

'     Returns the contents of the last non-empty cell in a row

      Application.Volatile 

     With rng.Parent

          With .Cells(rng.Row, .Columns.Count)

              If Not IsEmpty(.Value) Then

                  LASTINROW = .Value

              ElseIf IsEmpty(.End(xlToLeft)) Then

                  LASTINROW = ""

              Else

                  LASTINROW = .End(xlToLeft).Value

              End If

           End With

      End With

End Function

Does a String Match a Pattern?

Function ISLIKE(text As String, pattern As String) As Boolean

'     Returns true if the first argument is like the second

      ISLIKE = text Like pattern

End Function

Extracting the nth Element from a String

Function EXTRACTELEMENT(Txt, n, Separator) As String

'     Returns the nth element of a text string, where the

'     elements are separated by a specified separator character

      Dim AllElements As Variant

      AllElements = Split(Txt, Separator)

      EXTRACTELEMENT = AllElements(n - 1)

End Function

A Multifunctional Function

Function STATFUNCTION(rng, op)

      Select Case UCase(op)

          Case "SUM"

              STATFUNCTION = WorksheetFunction.Sum(rng)

          Case "AVERAGE"

              STATFUNCTION = WorksheetFunction.Average(rng)

          Case "MEDIAN"

              STATFUNCTION = WorksheetFunction.Median(rng)

          ‘……

      End Select

End Function

The SHEETOFFSET Function

Function SHEETOFFSET(Offset As Long, Optional Cell As Variant)

'    Returns cell contents at Ref, in sheet offset

      Dim WksIndex As Long, WksNum As Long

      Dim wks As Worksheet

      Application.Volatile

      If IsMissing(Cell) Then Set Cell = Application.Caller

      WksNum = 1

      For Each wks In Application.Caller.Parent.Parent.Worksheets

          If Application.Caller.Parent.Name = wks.Name Then

              SHEETOFFSET = Worksheets(WksNum + Offset).Range(Cell(1).Address)

              Exit Function

          Else

              WksNum = WksNum + 1

          End If

      Next wks

End Function

Returning the Maximum Value Across All Worksheets

Function MAXALLSHEETS(cell)

      Dim MaxVal As Double

      Dim Addr As String

      Dim Wksht As Object

      Application.Volatile

      Addr = cell.Range("A1").Address

      MaxVal = -9.9E+307

      For Each Wksht In cell.Parent.Parent.Worksheets

          If Wksht.Name = cell.Parent.Name And _

            Addr = Application.Caller.Address Then

          ' avoid circular reference

          Else

              If IsNumeric(Wksht.Range(Addr)) Then

                  If Wksht.Range(Addr) > MaxVal Then _

                    MaxVal = Wksht.Range(Addr).Value

              End If

          End If

      Next Wksht

      If MaxVal = -9.9E+307 Then MaxVal = 0

      MAXALLSHEETS = MaxVal

End Function

Returning an Array of Nonduplicated Random Integers

Function RANDOMINTEGERS()

      Dim FuncRange As Range

      Dim V() As Variant, ValArray() As Variant

      Dim CellCount As Double

      Dim i As Integer, j As Integer

      Dim r As Integer, c As Integer

      Dim Temp1 As Variant, Temp2 As Variant

      Dim RCount As Integer, CCount As Integer

      Randomize

'     Create Range object

      Set FuncRange = Application.Caller

'     Return an error if FuncRange is too large

      CellCount = FuncRange.Count

      If CellCount > 1000 Then

          RANDOMINTEGERS = CVErr(xlErrNA)

          Exit Function

      End If

'     Assign variables

      RCount = FuncRange.Rows.Count

      CCount = FuncRange.Columns.Count

      ReDim V(1 To RCount, 1 To CCount)

      ReDim ValArray(1 To 2, 1 To CellCount)

'     Fill array with random numbers

'     and consecutive integers

      For i = 1 To CellCount

          ValArray(1, i) = Rnd

          ValArray(2, i) = i

      Next i

'     Sort ValArray by the random number dimension

      For i = 1 To CellCount

          For j = i + 1 To CellCount

              If ValArray(1, i) > ValArray(1, j) Then

                  Temp1 = ValArray(1, j)

                  Temp2 = ValArray(2, j)

                  ValArray(1, j) = ValArray(1, i)

                  ValArray(2, j) = ValArray(2, i)

                  ValArray(1, i) = Temp1

                  ValArray(2, i) = Temp2

              End If

          Next j

      Next i

'     Put the randomized values into the V array

      i = 0

      For r = 1 To RCount

          For c = 1 To CCount

              i = i + 1

              V(r, c) = ValArray(2, i)

          Next c

      Next r

      RANDOMINTEGERS = V

End Function

Randomizing a Range

Function RANGERANDOMIZE(rng)

      Dim V() As Variant, ValArray() As Variant

      Dim CellCount As Double

      Dim i As Integer, j As Integer

      Dim r As Integer, c As Integer

      Dim Temp1 As Variant, Temp2 As Variant

      Dim RCount As Integer, CCount As Integer

     Randomize

'     Return an error if rng is too large

      CellCount = rng.Count

      If CellCount > 1000 Then

          RANGERANDOMIZE = CVErr(xlErrNA)

          Exit Function

      End If

'     Assign variables

      RCount = rng.Rows.Count

      CCount = rng.Columns.Count

      ReDim V(1 To RCount, 1 To CCount)

      ReDim ValArray(1 To 2, 1 To CellCount)

'     Fill ValArray with random numbers

'     and values from rng

      For i = 1 To CellCount

          ValArray(1, i) = Rnd

          ValArray(2, i) = rng(i)

      Next i

'     Sort ValArray by the random number dimension

      For i = 1 To CellCount

          For j = i + 1 To CellCount

              If ValArray(1, i) > ValArray(1, j) Then

                  Temp1 = ValArray(1, j)

                  Temp2 = ValArray(2, j)

                  ValArray(1, j) = ValArray(1, i)

                  ValArray(2, j) = ValArray(2, i)

                  ValArray(1, i) = Temp1

                  ValArray(2, i) = Temp2

              End If

          Next j

      Next i

'     Put the randomized values into the V array

      i = 0

      For r = 1 To RCount

          For c = 1 To CCount

              i = i + 1

              V(r, c) = ValArray(2, i)

          Next c

      Next r

      RANGERANDOMIZE = V

End Function