Excel VBA实现含N/A值的多列动态加权评分计算

需求规则 #

• 表格共1000行数据，每行设6个评分列，单列表分取值为1-5或N/A
• 6列初始权重依次为30%、20%、20%、10%、15%、5%，无N/A时直接按初始权重加权求和，计算示例：5*0.3 + 2*0.2 + 1*0.1 + 1*0.15 + 5*0.05 = 2.4
• 权重重分配规则：所有N/A列的原有权重总和，平均分摊给剩余有效评分列，不按原权重比例二次分配。例：首列（权重30%）为N/A时，剩余5列每列额外分摊30%/5=6%权重，调整后权重为26%、26%、16%、21%、11%；若存在2个N/A列，则两列总权重平均分摊给剩余4个有效列，多列N/A逻辑以此类推
• 要求实现1000行数据批量计算，支持拖拽填充时自动适配行位置，无需逐行修改公式/代码

现存问题 #

原有测试代码仅支持固定单元格计算，拖拽填充时无法动态匹配行号，代码如下：

Option Explicit
Function New_Score()
End Function
Sub TestSum()
   ' 固定Range引用写法，仅对第2行生效
   If Range("AD2").Value = "N/A" And Range("AF2").Value = 2 Then
   Range("AJ2").Value = (Range("AF2").Value * 0.3) + (Range("AH2").Value * 0.2)
   End If
   ' ActiveCell偏移写法，无法适配批量拖拽填充场景
   If ActiveCell.Offset(0, -2).Value = "N/A" And ActiveCell.Offset(0, -1).Value = 5 Then
   ActiveCell.Value = (ActiveCell.Offset(0, -3).Value * 0.3) + (ActiveCell.Offset(0, -1).Value * 0.2)
   End If
End Sub

可直接复用的实现方案 #

无需编写60组if-then-else枚举所有N/A组合，通过逻辑遍历自动计算调整后权重即可。

方案1：自定义函数（推荐，支持单元格拖拽） #

按Alt+F11打开VBA编辑器，插入标准模块，粘贴以下代码后回到表格界面，在第一行综合评分单元格输入公式=New_Score(AD2:AI2)（括号内为当前行6个评分列的范围，可根据实际列位置调整），按回车后下拉填充至1000行即可自动完成所有计算：

Option Explicit
Public Function New_Score(scoreRng As Range) As Variant
    ' 校验传入范围是否为6个评分列
    If scoreRng.Columns.Count <> 6 Then
        New_Score = "请选择连续6个评分列"
        Exit Function
    End If
    
    ' 初始权重顺序与评分列从左到右顺序一一对应
    Dim baseWeights As Variant
    baseWeights = Array(0.3, 0.2, 0.2, 0.1, 0.15, 0.05)
    
    Dim scores As Variant
    scores = scoreRng.Value
    
    Dim naTotalWeight As Double, validCount As Integer
    naTotalWeight = 0
    validCount = 0
    Dim i As Integer
    
    ' 第一轮遍历：统计N/A列总权重、有效评分列数量
    For i = 1 To 6
        If UCase(CStr(scores(1, i))) = "N/A" Then
            naTotalWeight = naTotalWeight + baseWeights(i - 1)
        Else
            validCount = validCount + 1
        End If
    Next i
    
    ' 全列为N/A的特殊场景处理
    If validCount = 0 Then
        New_Score = "无有效评分"
        Exit Function
    End If
    
    ' 计算每个有效列额外分摊的权重
    Dim addWeight As Double
    addWeight = naTotalWeight / validCount
    
    Dim finalScore As Double
    finalScore = 0
    ' 第二轮遍历：按调整后权重计算综合评分
    For i = 1 To 6
        If UCase(CStr(scores(1, i))) <> "N/A" Then
            ' 校验评分值合法性
            If Not IsNumeric(scores(1, i)) Or scores(1, i) < 1 Or scores(1, i) > 5 Then
                New_Score = "第" & i & "列评分值非法"
                Exit Function
            End If
            finalScore = finalScore + scores(1, i) * (baseWeights(i - 1) + addWeight)
        End If
    Next i
    
    ' 结果保留2位小数，可按需修改保留位数
    New_Score = Round(finalScore, 2)
End Function

方案特性：

• 自动适配任意数量、任意位置的N/A值，无需手动枚举组合
• 和Excel内置函数用法完全一致，拖拽填充时自动匹配每行的评分区域
• 自带值校验，非法评分、全N/A场景会返回明确提示
• 计算效率高，1000行数据可瞬时完成计算

方案2：一键批量计算宏 #

如果不需要在单元格保留公式，可使用以下宏一键完成全量计算，使用前需根据实际表格修改列号、起止行参数：

Sub BatchCalcAllScores()
    Dim ws As Worksheet
    Set ws = ActiveSheet ' 可替换为指定工作表，如 Set ws = Sheets("评分表")
    
    ' 表格参数配置，根据实际情况修改
    Const startRow As Long = 2 ' 数据起始行，表头为第1行则填2
    Const endRow As Long = 1001 ' 数据结束行，共1000行数据则填1001
    Const firstScoreCol As Integer = 30 ' 第一个评分列列号，AD列对应30
    Const lastScoreCol As Integer = 35 ' 最后一个评分列列号，AI列对应35
    Const resultCol As Integer = 36 ' 综合评分输出列列号，AJ列对应36
    
    Dim baseWeights As Variant
    baseWeights = Array(0.3, 0.2, 0.2, 0.1, 0.15, 0.05)
    
    Dim r As Long, i As Integer, naTotalWeight As Double, validCount As Integer
    Dim addWeight As Double, finalScore As Double
    
    For r = startRow To endRow
        naTotalWeight = 0
        validCount = 0
        ' 统计N/A权重与有效列数
        For i = firstScoreCol To lastScoreCol
            If UCase(CStr(ws.Cells(r, i).Value)) = "N/A" Then
                naTotalWeight = naTotalWeight + baseWeights(i - firstScoreCol)
            Else
                validCount = validCount + 1
            End If
        Next i
        
        If validCount = 0 Then
            ws.Cells(r, resultCol).Value = "无有效评分"
            GoTo NextRowHandle
        End If
        
        addWeight = naTotalWeight / validCount
        finalScore = 0
        ' 计算当前行综合评分
        For i = firstScoreCol To lastScoreCol
            If UCase(CStr(ws.Cells(r, i).Value)) <> "N/A" Then
                finalScore = finalScore + ws.Cells(r, i).Value * (baseWeights(i - firstScoreCol) + addWeight)
            End If
        Next i
        ws.Cells(r, resultCol).Value = Round(finalScore, 2)
NextRowHandle:
    Next r
    MsgBox "全量评分计算完成！"
End Sub

内容的提问来源于stack exchange，提问作者Gregg Rosenstein