Work Breakdown Structure Numbering in Excel
I’ve never heard of Work Breakdown Structure (WBS) before, but I’ve definitely seen it. It’s that type of numbering I see in lawerly type documents. It looks like this:
Jeremy has seen it before and wrote an Excel macro to number an Excel list based on indentation.
It seemed to work well for me. Well, I didn’t read the instructions first which put me in an infinite loop. But once I broke out of that, read the instructions, and reformatted my data, it worked. In that regard, I’d add a If r > Rows.Count Then Exit Do in there just for good measure. Of course, I would use class modules to do this, but then Mike Alexander would just make fun of me for it. 
I had a go at something similar: a generic tree-walker that could do different actions. The particular case was creating a directory tree corresponding to the indented list. However, you could easily generate nested numbering. I used an instance of a linked List class to hold the path.
See here: http://roymacleanvba.wordpress.com/2009/02/06/creating-a-directory-structure/
Friends don’t let friends abuse Class Modules.
Dick,
If you have never heard of WBS, it can only mean that you don’t plan your projects!
Nested subsection numbers can be done with formulas. It helps to define an array referring to a sequence of integers from 1 to something reasonable, in this case 32 should be sufficient. So something like the name nums referring to the constant array {1;2;3;4;5;6;7;8;9;10;11;12;13;14;15;16;17;18;19;20;21;22;23;24;25;26;27;28;29;30;31;32}.
If the topmost entry were in cell B2 and had no indentation, enter 1 in cell A2. For subsequent entries in column B, the column A formulas would be like so (here the formula for cell A3).
=CHOOSE(2+SIGN(FIND(LEFT(TRIM(B2),1),B2)-FIND(LEFT(TRIM(B3),1),B3)),A2&”.1″,
LEFT(A2,LOOKUP(2,1/(MID(”.”&A2,nums,1)=”.”),nums)-1)
&(MID(A2,LOOKUP(2,1/(MID(”.”&A2,nums,1)=”.”),nums),3)+1),
LEFT(LOOKUP(2,1/(FIND(LEFT(TRIM(B$2:B2),1),B$2:B2)
=FIND(LEFT(TRIM(B3),1),B3)),A$2:A2),
LOOKUP(2,1/(MID(”.”&LOOKUP(2,1/(FIND(LEFT(TRIM(B$2:B2),1),B$2:B2)
=FIND(LEFT(TRIM(B3),1),B3)),A$2:A2),nums,1)=”.”),nums)-1)
&(MID(LOOKUP(2,1/(FIND(LEFT(TRIM(B$2:B2),1),B$2:B2)
=FIND(LEFT(TRIM(B3),1),B3)),A$2:A2),
LOOKUP(2,1/(MID(”.”&LOOKUP(2,1/(FIND(LEFT(TRIM(B$2:B2),1),B$2:B2)
=FIND(LEFT(TRIM(B3),1),B3)),A$2:A2),nums,1)=”.”),nums),3)+1))
Rather long. If you’re willing to use a few more defined names involving partially or fully relative range addresses, you could define the following names with cell A3 the active cell.
type: =2+SIGN(FIND(LEFT(TRIM(B2),1),B2)-FIND(LEFT(TRIM(B3),1),B3))
base: =LOOKUP(2,1/(MID(”.”&A2,nums,1)=”.”),nums)
prev: =LOOKUP(2,1/(FIND(LEFT(TRIM(B$2:B2),1),B$2:B2)=FIND(LEFT(TRIM(B3),1),B3)),A$2:A2)
base.prev: =LOOKUP(2,1/(MID(”.”&prev,nums,1)=”.”),nums)
Then the cell A3 formula reduces to
=CHOOSE(type,A2&”.1″,LEFT(A2,base-1)&(MID(A2,base,3)+1),LEFT(prev,base.prev-1)&(MID(prev,base.prev,3)+1))
Too bad no twisty snippet on the number 1. This would allow users to hide/show rows that had 1.1 througn 1.9.
I wrote something similar for automatically indenting rows; that is, using the Outline feature of Excel. I work with a lot of Bill of Materials files, and many of these are multi-level explosions. Management likes indented files so that they can collapse and expand rows at will. I wrote this macro to take advantage of a “Level” column and a given data table.
This code is extremely fast, even with 30,000+ rows of data. I haven’t updated this code in a while, it hasn’t been rigorously tested, and it only works on the ActiveSheet, but it could be easily modified to meet people’s needs (I will eventually do that myself). Hopefully, it will do someone some good.
' Comments: This subroutine groups a spreadsheet into the
' same structure as the CAD tree.
'
' Arguments: lLevelCol The column containing level info
' lStartRow The first row of data within the data table
'
' Date Developer Action
' ----------------------------------------------------------------
' 01 Jul 06 Matthew Pfluger Initial version
' 17 Jan 07 Matthew Pfluger Corrected bugs with textual levels,
' program stopping before end
' 10 Apr 08 Matthew Pfluger Added function to convert asterisks in the Level
' column to numeric value based on length
' 15 Apr 08 Matthew Pfluger Code commenting and renaming of variables
' 29 Apr 08 Matthew Pfluger Changed logic that warns of exceeding Excel's max outline levels
' 08 May 08 Matthew Pfluger Corrected bug when grouping to second-to-last row
' 05 Mar 09 Matthew Pfluger Changed code so that lNumOfRows counts used rows in iLevelCol, not always column 1
Public Function bApplyOutlining(ByVal lLevelCol As Integer, ByVal lStartRow As Long)
' Error handling
Const sSOURCE As String = "bApplyOutlining"
Dim bReturn As Boolean ' the function return value
bReturn = True ' assume success
On Error GoTo ErrorHandler
' Reset existing outlining
RemoveOutlining
Dim bGroupFlag As Boolean ' a Boolean flag signaling that a gathering has been detected and will be grouped
Dim lCount As Long ' temp integer variable for counting and looping
Dim iCurLevel As Integer ' Current level; used to convert text to number
Dim iStartLevel As Integer ' Start level; used to convert text to number
Dim iMaxLevel As Integer ' the maximum value in the Level column
Dim lCurrentRow As Long ' the row number of the current row
Dim lGroupLevelThreshold As Long ' the minimum level a row must have in order to be grouped (Excel can only group 8 levels deep); not hardcoded to 8 so that one could group from 15 - 20 for example
Dim lNumOfRows As Long ' the row number of the last row in the active sheet
Dim rngLevelInfo As Range ' the range of level information
Dim rng As Range ' temp range variable
' Initialize Variables
bGroupFlag = False
lNumOfRows = Cells(Application.Rows.Count, lLevelCol).End(xlUp).row
Set rngLevelInfo = Range(Cells(lStartRow, lLevelCol), Cells(lNumOfRows, lLevelCol))
' Find max level and define minimum level in order to be grouped
iMaxLevel = Application.WorksheetFunction.Max(rngLevelInfo)
lGroupLevelThreshold = iMaxLevel - 7 ' Only highest eight levels will be grouped (Excel 2003 limits to 8 levels only)
' Change outline settings
With ActiveSheet.Outline
.SummaryRow = xlAbove
End With
' Process rows until the first blank line
Do Until (lStartRow >= lNumOfRows)
lCurrentRow = lStartRow + 1
' Coerce level value to integer
iStartLevel = CInt(Cells(lStartRow, lLevelCol).Value)
If (iStartLevel >= lGroupLevelThreshold) Then ' If row's level doesn't exceed lGroupLevelThreshold
' until current row's level exceeds or is equal to starting row's
iCurLevel = CInt(Cells(lCurrentRow, lLevelCol).Value)
' Find the end of current group
Do Until (iStartLevel >= iCurLevel Or lCurrentRow > lNumOfRows)
lCurrentRow = lCurrentRow + 1 ' If a group is found, set flag to true
bGroupFlag = True
' Get level of current row
iCurLevel = CInt(Cells(lCurrentRow, lLevelCol).Value)
Loop
' If a group is found
If (bGroupFlag) Then
' Group all rows under lStartRow to current row
Rows(lStartRow + 1 & ":" & lCurrentRow - 1).group
' Reset flag
bGroupFlag = False
End If
End If
lStartRow = lStartRow + 1
Loop
Range("a1").Select
' Notify user if some levels were not grouped
iStartLevel = Application.WorksheetFunction.Min(rngLevelInfo)
If iMaxLevel - iStartLevel + 1 > 8 Then
Call MsgBox("There were too many sublevels in " & ActiveSheet.Name & " to group completely. " & _
"Since Excel currently allows only 8 grouping levels, the level(s) 0 - " & lGroupLevelThreshold - 1 & " were not grouped.")
End If
ErrorExit:
' Return result
bApplyOutlining = bReturn
Exit Function
ErrorHandler:
' An error is reached if level information cannot be interpreted. In such case,
' the macro removes outlining and notifies the user.
MsgBox ("An unexpected error occured. It is likely that your " & _
"level column contained text rather than only numbers. " & _
"The data will be restored to its original form.")
Call RemoveOutlining
' Set return value to False to tell caller something went wrong
bReturn = False
Resume ErrorExit
End Function
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Comments: This procedure removes all tree formatting from the
' bApplyOutlining macro.
'
' Date Developer Action
' --------------------------------------------------------------
' 05 Sep 07 Matthew Pfluger Initial version
' 14 Apr 08 Matthew Pfluger Moved "reset last cell" to separate function
' Changed name
Public Sub RemoveOutlining()
On Error Resume Next
' Format all cells
With Cells
.Rows.OutlineLevel = 1 ' Remove row outlining
.Columns.OutlineLevel = 1 ' Remove column outlining
.EntireRow.Hidden = False ' Unhide all rows
.EntireColumn.Hidden = False ' Unhide all columns
End With
ResetLastCell
End Sub
My apologies in advance if the code doesn’t copy correctly. Thanks to all MVPs out there for all your help in the past.
Matthew Pfluger
Just a point of clarification… A WBS is not the numbering system itself. WBS is a project management system designed to capture 100% of the project scope by defining milestones as nouns(deliverables) with specific costs, not verbs(tasks/actions). And then, there is a terribly long list of WBS do’s and dont’s. The genesis of the system was in the 50’s and it is now required for virtually all military projects.
The WBS “rules” can be found here: http://www.acq.osd.mil/pm/currentpolicy/wbs/MIL_HDBK-881A/MILHDBK881A/WebHelp3/MILHDBK881A.htm
and Wikipedia has a decent description: http://en.wikipedia.org/wiki/Work_breakdown_structure
Hi Matthew,
The code looks amazing and is just what I was searching for.
The only problem I have is when i paste it to my excel VBA editor it comes with a lot of “Pasting Problems” It shows syntax errors.
I would like to ask you pleas if you can send me an excel file with the code inside working already. My e-mail is: catuso.shz@gmail.com
I will appreciate a lot all your help.
Best regards,
Sergio.