WBS Function

[dflak]

This function produces a Work Breakdown Schedule (WBS)-like numbering system such as:

1
1.1
1.2
1.2.1
2
2.1
2.1.1

The function can start in any cell, and the first occurrence of the function is automatically assigned the value "1." Subsequent occurrences of the function in the same column will increment the counter or level depending on the indent level of the cell immediately to the right. No indent is N, indent 1 is N.N, Indent 2 is N.N.N, etc. You can have as many indents as needed. Just copy the formula down for as many tasks as you have and indent the tasks accordingly.

I could probably do a bit more cleanup of the code, but I'm lazy.

Function WBS() As String
Dim MyCell As String            ' The address of the cell calling the function
Dim MyRow As Long               ' Row of the function
Dim MyCol As Long               ' Column of the function
Dim MyLevel As Long             ' Level of the cell to the right of the function
Dim UpLevel As Long             ' Level of the cell one up and to the right of the function

Dim Firstrow As Long            ' First row with this formula
Dim i As Long                   ' Row index
Dim rng As Range                ' For find command

Dim PrevVal As String           ' Value of the previous level
Dim PrevArr() As String         ' Array holding the parts
Dim NewVal As String            ' New value of string

Application.Volatile

' Initalize variables
MyCell = ThisCell

MyRow = Range(MyCell).Row
MyCol = Range(MyCell).Column
MyLevel = Range(MyCell).Offset(0, 1).IndentLevel
UpLevel = Range(MyCell).Offset(-1, 1).IndentLevel
PrevVal = Range(MyCell).Offset(-1, 0).Value

' Is this the first row?
Set rng = Range(Cells(1, MyCol), Cells(MyRow, MyCol)).Find("WBS", LookIn:=xlFormulas, lookat:=xlPart)
If rng.Row = MyRow Then
    WBS = 1
    Exit Function
End If

' Otherwise remember the first row.
Firstrow = rng.Row

'Compare the level of the previous task with the current task
If UpLevel = MyLevel Then
    ' Add one to the last digit
    PrevArr = Split(PrevVal, ".")
    PrevArr(UBound(PrevArr)) = PrevArr(UBound(PrevArr)) + 1
    WBS = Join(PrevArr, ".")
ElseIf UpLevel < MyLevel Then
    ' Append .1 to the string
    WBS = PrevVal & ".1"
ElseIf UpLevel > MyLevel Then
    ' Find previous task with that level and add one to last digit
    For i = MyRow - 1 To Firstrow Step -1
        If Cells(i, MyCol).Offset(0, 1).IndentLevel = MyLevel Then
            PrevVal = Cells(i, MyCol)
            Exit For
        End If
    Next i
    PrevArr = Split(PrevVal, ".")
    PrevArr(UBound(PrevArr)) = PrevArr(UBound(PrevArr)) + 1
    WBS = Join(PrevArr, ".")
Else
    ' We should never get here
    WBS = "???"
End If

End Function

Function ThisCell() As String
    ThisCell = Application.Caller.Worksheet.Cells(Application.Caller.Row, Application.Caller.Column).Address
End Function