在 VBA 中使用默认值数组用大纲填充 Excel WBS

Question

我有一个

WBS

（工作分解结构），有多行（组大纲的顶层），每个顶层行都是一个活动。直接位于活动之下的是所涉及的角色。

根据顶层活动的值（例如“计划”），根据另一张工作表（“默认”选项卡）上相关表中的值填充下层中的单元格。

当前，活动下的行（对应于角色）正在执行丑陋的索引/匹配查找，乘以 25 个角色，可以使电子表格陷入停顿。

我认为解决这个问题的方法是获取角色默认值表，将其放入持久数组中，并在用户放入顶级活动时一遍又一遍地使用数组中的值。我只是不知道如何使数组持久化（因此每次用户更改单元格时 VBA 都不会重新填充它）。如果“角色默认值”表中的值发生变化，我可以使用工作表 OnChange

 来处理，所以这不是问题。 

第 3 行“活动 1”是活动行在组大纲折叠后的样子。

第 4-9 行是活动行在组大纲展开后的样子，显示了基础角色。

对于每个角色，这是另一个选项卡上的表格，用于查找

WBS

选项卡上相应活动/角色单元格中应包含的值。

Answer 1

我支持在需要查找时使用

Dictionary

 对象。在下面的解决方案中，我使用嵌套字典返回顶级和活动的组合。 （注：我试图尽可能地了解您的业务需求，但我确信我没有做到这一点。我还假设了一些高于初学者水平的 VBA 知识。如果您有后续问题，请询问并我们会尽力提供帮助）。

首先，创建一个新模块来保存全局可用的

Dictionary

。这不能是 

Worksheet

 模块。 （在 VBE 中，转到插入 --> 模块）。在模块的最顶部，在创建子例程之前，声明一个公开可用的 

Dictionary

Public oDictWbs As Object 我们只想要这本字典的一个实例，所以我喜欢使用类似

Singleton

 的模式，如果已经创建，则返回 

Dictionary

，如果没有，则创建并返回一个新的。 （注意：我将返回新字典的例程分解为 

RefreshWBS

 ，以便它可用于根据您的业务规则创建新字典。因此，例如，在默认工作表 

OnChange

 事件中，您可以致电 

RefreshWBS

 [代码重用总是很有趣]）。

Private Function GetWBS() As Object
    If Not oDictWbs Is Nothing Then
        Set GetWBS = oDictWbs
        Exit Function
    End If

    Set GetWBS = RefreshWBS()
End Function

Private Function RefreshWBS()
    Dim sDefault As Worksheet
    Dim rTopLevels As Range
    Dim rActivities As Range
    Dim rIterator As Range
    Dim rInnerIter As Range

    Set oDictWbs = Nothing
    'Both variables below establish the range that stores the fixed info (the default worksheet)
    'Instead of hard coding in the range, create your own logic based on your needs and rules
    Set sDefault = Sheets("Default")
    Set rTopLevels = sDefault.Range("B1:C1")
    Set rActivities = sDefault.Range("A3:A4")

    Set oDictWbs = CreateObject("Scripting.Dictionary")

    For Each rIterator In rTopLevels
        If Not oDictWbs.exists(rIterator.Value) Then
            Set oDictWbs(rIterator.Value) = CreateObject("Scripting.Dictionary")
        End If

        For Each rInnerIter In rActivities
            If Not oDictWbs(rIterator.Value).exists(rInnerIter.Value) Then
                oDictWbs(rIterator.Value)(rInnerIter.Value) = sDefault.Cells(rInnerIter.Row, rIterator.Column)
            End If
        Next rInnerIter
    Next rIterator

    Set RefreshWBS = oDictWbs

End Function

最后，我们创建一个可以从工作表本身访问的函数，允许用户访问 WBS 词典中的信息。您可以在 Excel 单元格中输入类似

=GetWbsActivityTime(B1, A4)

 的函数，假设单元格 B1 包含顶级描述符，A4 描述活动。只要该值在字典中，它就会返回与其关联的值。

Function GetWbsActivityTime(sTopLevel As String, sActivity As String) As Variant
    Dim oDict As Object

    Set oDict = GetWBS()

    If Not oDict.exists(sTopLevel) Then
        GetWbsActivityTime = CVErr(xlErrRef)
        Exit Function
    End If

    If Not oDict(sTopLevel).exists(sActivity) Then
        GetWbsActivityTime = CVErr(xlErrRef)
        Exit Function
    End If

    GetWbsActivityTime = oDict(sTopLevel)(sActivity)
End Function

我知道需要吸收的内容很多，因此请查看它并让我知道我可以提供帮助的任何问题或怪癖。另外，如果我完全错过了练习的重点，请告诉我，我会看看我们是否可以挽救部分解决方案。

Answer 2

我用数组对此进行了一些简化，并添加了 a 列，其中 1、2 或 3 代表轮廓级别。您可以按照代码逻辑添加更多级别。

Sub WBS_Array()


Dim arr(0 To 3) As Variant
   Dim lastrow, i As Integer
   
   lastrow = Cells(Rows.Count, 1).End(xlUp).row
      For i = 1 To lastrow
         Cells(i, 1).Select
         With Selection
            If Selection.Value = 1 Then
               arr(1) = arr(1) + 1
               ActiveCell.Offset(0, 1).Value = arr(1)
               Else:
                  If Selection.Value = 2 Then
                     arr(2) = arr(2) + 1
                     If ActiveCell.Offset(-1, 0).Value = ActiveCell.Value Then
                        ActiveCell.Offset(0, 1).Value = arr(1) & "." & arr(2)
                        Else:
                           arr(2) = 1
                           ActiveCell.Offset(0, 1).Value = arr(1) & "." & arr(2)
                           If ActiveCell.Offset(-1, 0).Value > ActiveCell.Value Then
                              ActiveCell.Offset(0, 1).Value = arr(1) & "." & arr(2) + 1
                           End If
                     End If
                  Else:
                     If Selection.Value = 3 Then
                        arr(3) = arr(3) + 1
                        If ActiveCell.Offset(-1, 0).Value = ActiveCell.Value Then
                           ActiveCell.Offset(0, 1).Value = arr(1) & "." & arr(2) & "." & arr(3)
                           Else:
                              arr(3) = 1
                              ActiveCell.Offset(0, 1).Value = arr(1) & "." & arr(2) & "." & arr(3)
                        End If
                     End If
                  End If
            End If
         End With
      Next i

End Sub