Excel新增工人后分配值无法同步移动的VBA代码修复需求

问题分析 #

当前VBA代码仅在点击按钮时对现有行执行赋值计算，当Calendar表新增工人行后，新增行不会自动触发计算；同时原代码依赖列索引偏移的方式易出错，循环效率也较低。

解决方案 #

方案1：优化VBA代码，确保覆盖所有行（包括新增行） #

优化后的代码改用ListObject的ListRow对象遍历表格，避免列索引计算错误，同时提升统计效率：

Sub Refresh()
    On Error GoTo ErrorHandler

    Dim ws As Worksheet
    Dim planTbl As ListObject
    Dim calendarTbl As ListObject
    Dim planRow As ListRow
    Dim calRow As ListRow
    Dim selectedDate As Date
    Dim utilaj As String
    Dim workerDict As Object
    Dim planValue As Double
    Dim faptValue As Double

    Set ws = ThisWorkbook.Sheets("Sheet1")
    Set planTbl = ws.ListObjects("PlanTable")
    Set calendarTbl = ws.ListObjects("Calendar")

    ' 初始化字典，用「日期|机器」作为键存储工人数
    Set workerDict = CreateObject("Scripting.Dictionary")

    ' 一次性统计所有日期+机器的工人数
    For Each calRow In calendarTbl.ListRows
        selectedDate = calRow.Range(calendarTbl.ListColumns("Data").Index).Value
        utilaj = calRow.Range(calendarTbl.ListColumns("Utilaj").Index).Value
        Dim key As String
        key = Format(selectedDate, "dd-mmm-yy") & "|" & utilaj
        workerDict(key) = workerDict(key) + 1
    Next calRow

    ' 清空Fapt列旧值，避免残留数据
    calendarTbl.ListColumns("Fapt").DataBodyRange.ClearContents

    ' 遍历PlanTable计算并分配Fapt值
    For Each planRow In planTbl.ListRows
        selectedDate = planRow.Range(planTbl.ListColumns("Data").Index).Value
        utilaj = planRow.Range(planTbl.ListColumns("Utilaj").Index).Value
        planValue = planRow.Range(planTbl.ListColumns("Plan").Index).Value

        Dim lookupKey As String
        lookupKey = Format(selectedDate, "dd-mmm-yy") & "|" & utilaj

        If workerDict.Exists(lookupKey) Then
            faptValue = planValue / workerDict(lookupKey)
            ' 匹配Calendar表对应行赋值
            For Each calRow In calendarTbl.ListRows
                If calRow.Range(calendarTbl.ListColumns("Data").Index).Value = selectedDate And _
                   calRow.Range(calendarTbl.ListColumns("Utilaj").Index).Value = utilaj Then
                    calRow.Range(calendarTbl.ListColumns("Fapt").Index).Value = faptValue
                End If
            Next calRow
        Else
            Debug.Print "未找到日期 " & Format(selectedDate, "dd-mmm-yy") & " 机器 " & utilaj & " 的工人记录"
        End If
    Next planRow

    MsgBox "分配值已更新完成！"
    Exit Sub

ErrorHandler:
    MsgBox "错误代码 " & Err.Number & ": " & Err.Description
End Sub

优化点说明

• 用ListRow遍历表格，避免列索引偏移的潜在错误，代码更易维护
• 一次性统计所有工人数，减少循环次数，提升运行效率
• 清空旧值再赋值，避免新增行残留无效数据
• 用「日期|机器」作为字典键，确保统计的唯一性

方案2：使用Excel动态公式，无需VBA自动计算 #

如果不需要VBA，可直接在Calendar表的Fapt列第一个数据单元格输入以下公式（Excel 365直接回车，旧版按Ctrl+Shift+Enter作为数组公式）：

=IFERROR(INDEX(PlanTable[Plan], MATCH(1, (PlanTable[Data]=[@Data])*(PlanTable[Utilaj]=[@Utilaj]), 0))/COUNTIFS(Calendar[Data], [@Data], Calendar[Utilaj], [@Utilaj]), 0)

公式会自动匹配当前行的日期和机器，计算分配值，新增行时会自动继承公式并计算。

方案3：添加工作表事件，自动触发计算 #

若需要保留按钮触发+新增行自动更新，可在Sheet1的代码模块中添加以下事件代码：

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim calTbl As ListObject
    Set calTbl = Me.ListObjects("Calendar")
    ' 判断是否修改了Calendar表的数据区域
    If Not Intersect(Target, calTbl.DataBodyRange) Is Nothing Then
        ' 延迟1秒触发，避免数据未完全加载
        Application.OnTime Now + TimeValue("00:00:01"), "Refresh"
    End If
End Sub

此后新增工人行或修改Calendar表数据时，会自动运行Refresh宏更新分配值。

内容的提问来源于stack exchange，提问作者Dănilă Laurențiu