MS Project VBA自定义数据结构处理代码精简方案咨询

针对你代码中重复的Select Case逻辑，这里提供两种实用的精简方案，核心思路是消除重复代码块，通过统一的属性访问逻辑替代分支判断。

方案1：使用辅助函数抽离属性访问逻辑（无需修改原有数据结构） #

这种方法不需要改动你现有的SA_Array自定义类型，仅通过一个小辅助函数统一处理属性映射，主函数用循环替代重复的累加代码。

步骤1：添加属性访问辅助函数 #

在模块中新增一个私有函数，用来根据传入的属性名称返回对应的值：

Private Function GetSAProperty(elem As SA_Array, propName As String) As Single
    Select Case propName
        Case "SAT": GetSAProperty = elem.SAT
        Case "SOT": GetSAProperty = elem.SOT
        Case "PAT": GetSAProperty = elem.PAT
        Case "POT": GetSAProperty = elem.POT
        Case Else: GetSAProperty = 0 ' 处理无效属性名的默认值
    End Select
End Function

步骤2：重构qsM函数 #

移除原来的Select Case，用循环处理重复的累加逻辑：

Function qsM(stype As String) As String
    On Error Resume Next

    Dim qs, qa, qw As Single
    ' 定义需要参与计算的元素ID数组，后续扩展只需修改此数组
    Dim targetElems As Variant
    targetElems = Array(pMDurn, pMFixd, pMPred)

    ' 计算qa的分子部分
    qa = 0
    Dim elemID As Variant
    For Each elemID In targetElems
        qa = qa + GetSAProperty(SCHED_ANAL(elemID), stype) * SCHED_ANAL(elemID).WT
    Next elemID

    ' 处理除法逻辑
    Dim totalVal As Single
    totalVal = GetSAProperty(SCHED_ANAL(pMTotl), stype)
    If totalVal <> 0 Then qa = qa / totalVal

    ' 计算权重总和
    qw = 0
    For Each elemID In targetElems
        qw = qw + SCHED_ANAL(elemID).WT
    Next elemID

    ' 计算最终评分并格式化
    qs = (1 - qa / qw) * 100
    qsM = Format(qs, "#0.0")
End Function

方案2：改用类模块实现属性动态访问（更灵活的扩展方案） #

如果后续需要频繁扩展属性或逻辑，可以将SA_Array自定义类型替换为类模块，这样就能直接使用CallByName函数动态访问属性，彻底消除所有分支判断。

步骤1：创建类模块 #

1. 插入一个新的类模块，命名为clsSA
2. 在类模块中定义所有属性：

Public Item As String
Public SAT As Single
Public SOT As Single
Public PAT As Single
Public POT As Single
Public WT As Integer
Public Category As String
Public Description As String
Public Risk As String
Public ExecuteCheckbox As CheckBox
Public RepairButton As CommandButton

步骤2：修改全局变量声明 #

将原来的自定义类型数组替换为类实例数组，注意初始化时需要创建类实例：

Public Const NoAnalItems As Integer = 35
Public SCHED_ANAL(NoAnalItems) As clsSA

' 在初始化代码中添加（比如Workbook_Open或模块的初始化过程）
Private Sub InitializeSCHED_ANAL()
    Dim i As Integer
    For i = 0 To NoAnalItems
        Set SCHED_ANAL(i) = New clsSA
    Next i
End Sub

步骤3：重构qsM函数 #

直接用CallByName动态访问属性，代码更简洁：

Function qsM(stype As String) As String
    On Error Resume Next

    Dim qs, qa, qw As Single
    Dim targetElems As Variant
    targetElems = Array(pMDurn, pMFixd, pMPred)

    qa = 0
    Dim elemID As Variant
    For Each elemID In targetElems
        ' 动态获取指定属性的值
        qa = qa + CallByName(SCHED_ANAL(elemID), stype, vbGet) * SCHED_ANAL(elemID).WT
    Next elemID

    Dim totalVal As Single
    totalVal = CallByName(SCHED_ANAL(pMTotl), stype, vbGet)
    If totalVal <> 0 Then qa = qa / totalVal

    qw = 0
    For Each elemID In targetElems
        qw = qw + SCHED_ANAL(elemID).WT
    Next elemID

    qs = (1 - qa / qw) * 100
    qsM = Format(qs, "#0.0")
End Function

额外优化建议 #

• 给stype参数添加类型声明（As String），避免类型不匹配的错误
• 移除原代码中未使用的变量（比如Dim t As SA_Array）
• 可以将targetElems数组定义为模块级常量，避免每次函数调用都重新创建

内容的提问来源于stack exchange，提问作者Gary E. Didio