在项目管理中，WBS是项目最基本的工作联络图。可惜Excel中没有像Word那样设置多级列表自动加注序号功能，因此用Excel处理WBS元素之间的分级显示很是不便。尽管可以用数据的分级组合，但是，这种分级组合不太适应WBS的多级变化。在一个已经建好的分级组合中再插入一些WBS元素，或者改变某些WBS元素的级别，常常需要取消组合后，再去加入或者改变这些WBS元素，并重新选择分级组合，很是麻烦。

当然，一行一行地数，然后用手输入排序，也可以。只是容易让人眼花，还常常数错。
闲来编了一个程序，可以自动实现1、1.1、2、2.1、2.2、2.2.1、2.2.2等直到六级的多级别排序，实例如下图：

http://s1/middle/49ca96e7g7fbb84fde9c0&690

源程序见下，有兴趣的朋友可以试试。因为这种分级别方式也为记录、追踪工作状态和分析问题提供了一个明晰的工具。还有兴趣的朋友也可以再加上级别筛选功能，甚至对不同级别，采用条件格式，设置不同的颜色，那就更为美观和方便了。

Sub WBS()
Dim totalrow, a, b, level As Integer
Dim d, e, f, g4, g5, g6, h, i, j As Double
'定义变量类型
Application.ScreenUpdating = False
'暂时关闭屏幕刷新，可以加快运行速度
On Error Resume Next
'设定出错后，继续执行下一条语句
totalrow = ActiveWindow.ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row - 4
'从整个表格使用行数中将表头部分的行排除在外，也就是从第四行开始排序

a = 1
b = 1
e = 0.1
f = 0.1
i = 0.1
j = 0.1
'赋初值

Cells(a + 3, 1).Select

For a = 1 To totalrow
'从表体部分第一行开始循环执行排序工作
level = Cells(a + 3, 1).Value
If a > 1 Then
If Cells(a + 3, 1) - Cells(a + 2, 1) >= 2 Then
MsgBox ("第" + Str(a + 3) + "行WBS排序有错误！")
'出错检查，防止两个WBS级别相差大于2，比如从第一级直接跳入第三级
Exit Sub
'如果出现WBS级别错误，显示错误提示并退出程序
End If
End If

Select Case level
'针对WBS的不同的级别进行分别排序
Case 1
Cells(a + 3, 2) = b
b = b + 1
'第一级，也就是最高级时，这种情况直接从1、2、3、4这样排序，用b变量记录下一个高级别值
If Cells(a + 3, 2).IndentLevel <> 0 Then
Cells(a + 3, 2).IndentLevel = 0
'自动设置WBS文本右缩进值为0
End If

Case 2
d = 0.1
Cells(a + 3, 2) = Trim(Str(Val(Cells(a + 2, 2)) + Val(d)))
d = d + 0.1
'第二级，这种情况直接从在原来的WBS尾数后面以0.1为差进行累加，用d变量记录下一个高级别值
If Cells(a + 3, 2).IndentLevel <> 1 Then
Cells(a + 3, 2).IndentLevel = 1
End If

Case 3
If Cells(a + 2, 1) = 2 Then
e = 0.1
Cells(a + 3, 2) = Trim(Str(Val(Cells(a + 2, 2))) + Trim(Str(Val(e))))
Else
e = e + 0.1
Cells(a + 3, 2) = Trim(Str(Val(Cells(a + 2, 2))) + Trim(Str(Val(e))))
End If
If Cells(a + 3, 2).IndentLevel <> 2 Then
Cells(a + 3, 2).IndentLevel = 2
End If

Case 4

If Cells(a + 2, 1) = 3 Then
g4 = Cells(a + 2, 1).Row
f = 0.1
Cells(a + 3, 2) = Trim(Cells(a + 2, 2) + Trim(Str(Val(f))))
Else
f = f + 0.1
Cells(a + 3, 2) = Trim(Cells(g4, 2) + Trim(Str(Val(f))))
End If
If Cells(a + 3, 2).IndentLevel <> 3 Then
Cells(a + 3, 2).IndentLevel = 3
End If

Case 5

If Cells(a + 2, 1) = 4 Then
g5 = Cells(a + 2, 1).Row
i = 0.1
Cells(a + 3, 2) = Trim(Cells(a + 2, 2) + Trim(Str(Val(i))))
Else
i = i + 0.1
Cells(a + 3, 2) = Trim(Cells(g5, 2) + Trim(Str(Val(i))))
End If

If Cells(a + 3, 2).IndentLevel <> 4 Then
Cells(a + 3, 2).IndentLevel = 4
End If

Case 6

If Cells(a + 2, 1) = 5 Then
g6 = Cells(a + 2, 1).Row
j = 0.1
Cells(a + 3, 2) = Trim(Cells(a + 2, 2) + Trim(Str(Val(j))))
Else
j = j + 0.1
Cells(a + 3, 2) = Trim(Cells(g6, 2) + Trim(Str(Val(j))))
End If

If Cells(a + 3, 2).IndentLevel <> 5 Then
Cells(a + 3, 2).IndentLevel = 5
End If
End Select

Next a
Application.ScreenUpdating = True
'恢复屏幕刷新
End Sub