完美Excel

Sub WBSNumbering()
 
'为项目计划重新编号

'布局假设:
'第1行为列标题
'列A为WBS编号
'列B为工作任务描述,带有合适的缩进
'使用某文本(这里为"END OF PROJECT")表明任务列表结束

    On Error Resume Next
 
    '隐藏分页符并禁用屏幕更新,以加快代码的执行速度
    Application.ScreenUpdating = False
    ActiveSheet.DisplayPageBreaks = False
    '将编号列格式化为文本(以便保留0)
    ActiveSheet.Range("A:A").NumberFormat = "@"
    Dim r As Long                   '行计数
    Dim depth As Long               '每项任务有多少个"小数点"
    Dim wbsarray() As Long          '包含每项WBS层次计数的主控数组
    Dim basenum As Long             '完整数字顺序变量
    Dim wbs As String               '每项任务的WBS字符串
    Dim aloop As Long               '通用目的的For/Next循环计数

    r = 2                           '开始行
    basenum = 0                     '初始化完整的数字
    ReDim wbsarray(0 To 0) As Long  '初始化WBS枚举数组

    '遍历带有项目任务的单元格并产生WBS编号
    Do While Cells(r, 2) <> "END OF PROJECT"
 
        '忽略列B中的空任务
        If Cells(r, 2) <> "" Then
 
           '跳过隐藏行
            If Rows(r).EntireRow.Hidden = False Then
 
                '获取列B中任务的缩进级别
                depth = Cells(r, 2).IndentLevel
 
                '如果没有缩进(完整的数字,为一项控制任务)
                If depth = 0 Then
 
                    '增加WBS基数
                    basenum = basenum + 1
                    wbs = CStr(basenum)
                    ReDim wbsarray(0 To 0)
 
                '如果任务有缩进(为二级任务,三级任务,等等)
                Else
 
                    '根据当前的缩进深度调整WBS数组的大小
                    ReDim Preserve wbsarray(0 To depth) As Long
 
                    '重利用缩进深度以引用数组大小;数组以0开始
                    depth = depth - 1
 
                    '如果这是第一个二级任务
                    If wbsarray(depth) <> 0 Then
 
                        wbsarray(depth) = wbsarray(depth) + 1
 
                    '如果递增二级任务
                    Else
 
                        wbsarray(depth) = 1
 
                    End If
 
                    '仅枚举与缩进具有同样深度的WBS;
                    '清除代表更深层级的以前存储的值
                    If wbsarray(depth + 1) <> 0 Then
                        For aloop = depth + 1 To UBound(wbsarray)
                            wbsarray(aloop) = 0
                        Next aloop
                    End If
 
                    '将数组的内容赋给WBS字符串
                    wbs = CStr(basenum)
 
                    For aloop = 0 To depth
                        wbs = wbs & "." & CStr(wbsarray(aloop))
                    Next aloop
 
                End If
 
                '使用WBS编号填充目标单元格
                Cells(r, 1).Value = wbs
 
                '处理 "数字存储为文本" 错误
                Cells(r, 1).Errors(xlNumberAsText).Ignore = True
 
                '应用文本格式: 下一行比当前行层次更深
                If Cells(r + 1, 2).IndentLevel > Cells(r, 2).IndentLevel Then
 
                    Cells(r, 1).Font.Bold = True
                    Cells(r, 2).Font.Bold = True
                '否则下一行与当前行相同,无须格式
                Else
                    Cells(r, 1).Font.Bold = False
                    Cells(r, 2).Font.Bold = False
                End If
                '为主控任务使用特殊格式(完整的数字)
                If Cells(r, 2).IndentLevel = 0 Then
 
                    Cells(r, 1).Font.Bold = True
                    Cells(r, 2).Font.Bold = True
                    '可在此添加您希望的其它格式

                End If
 
            End If
 
        End If
 
        '到下一行
        r = r + 1
 
        If r > Rows.Count Then Exit Do
 
    Loop
 
End Sub