Excel VBA需求：点击A列单元格批量录入对应行C-F列数据

• 点击A2-A5任意单元格时，触发对应行C-F列的循环录入操作（原代码仅支持A2行）
• 每行C-F列录入的数值总和不得超过对应B列的数值
• 输入框需显示对应C-F列的表头日期，方便核对录入的日期与金额

示例表格 #

现有代码 #

Option Explicit

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    On Error GoTo ClearError

    Const iAddress As String = "A2:A5" 'Loopfor cells A3 to A5
    Const mrgAddress As String = "C2,D2,E2,F2" 'Keep merged cell range unchanged
                    
    Dim iCell As Range
    
    Set iCell = Intersect(Range(iAddress), Target)
    If iCell Is Nothing Then Exit Sub
    
    Dim mrg As Range: Set mrg = Range(mrgAddress)
    
    Application.EnableEvents = False
    
    Dim varEintrag As Variant
    
    For Each iCell In mrg.Cells
        
        varEintrag = Application.InputBox( _
          Prompt:="Enter Amount to '" & iCell.Address(0, 0) _
          & "' then press Enter:", _
          Title:="AMOUNT TO PAY FOR THIS WEEK", _
          Default:=iCell.value)
    
        If varEintrag <> "Falsch" And varEintrag <> "False" Then
            If IsNumeric(varEintrag) Then
                iCell.value = CDbl(varEintrag)
            Else
                iCell.value = varEintrag
            End If
        Else
            Exit For ' Cancel
        End If
    
    Next iCell

SafeExit:
    If Not Application.EnableEvents Then Application.EnableEvents = True

    Exit Sub

ClearError:
    Debug.Print "Run-time error '" & Err.Number & "': " & Err.Description
    Resume SafeExit
End Sub

优化后的代码 #

Option Explicit

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    On Error GoTo ClearError

    Const TRIGGER_RANGE As String = "A2:A5" ' 触发操作的单元格范围
    Const DATA_COLUMNS As String = "C:F"    ' 数据录入的列范围
    Const TOTAL_COLUMN As String = "B"      ' 总金额所在列

    Dim triggerCell As Range
    Set triggerCell = Intersect(Range(TRIGGER_RANGE), Target)
    If triggerCell Is Nothing Then Exit Sub ' 未点击目标范围，退出

    Dim currentRow As Long
    currentRow = triggerCell.Row ' 获取当前点击的行号

    Dim dataRange As Range
    Set dataRange = Range(DATA_COLUMNS).Rows(currentRow) ' 对应行的C-F列范围

    Dim totalLimit As Double
    ' 读取对应B列的总金额，为空则默认设为0
    totalLimit = IIf(IsEmpty(Cells(currentRow, TOTAL_COLUMN)), 0, CDbl(Cells(currentRow, TOTAL_COLUMN).Value))

    Application.EnableEvents = False ' 禁用事件避免重复触发

    Dim cell As Range
    Dim inputVal As Variant
    Dim currentSum As Double

    For Each cell In dataRange
        ' 计算当前C-F列已录入的总和
        currentSum = WorksheetFunction.Sum(dataRange)
        ' 输入框显示对应日期表头和剩余可录入金额
        inputVal = Application.InputBox( _
            Prompt:="日期：" & Cells(1, cell.Column).Value & vbCrLf & _
                    "当前已录入总和：" & currentSum & vbCrLf & _
                    "剩余可录入金额：" & totalLimit - currentSum & vbCrLf & _
                    "请输入金额：", _
            Title:="录入周付款金额", _
            Default:=cell.Value, _
            Type:=1) ' Type:=1 限制仅允许输入数字或点击取消

        If inputVal = False Then ' 用户点击取消，退出循环
            Exit For
        End If

        ' 验证输入金额加上当前总和是否超过限制
        If currentSum + inputVal > totalLimit Then
            MsgBox "输入金额超出剩余限额！剩余可录入：" & totalLimit - currentSum, vbExclamation
            GoTo NextCell ' 跳过当前单元格，继续下一个
        End If

        ' 写入合法的数值
        cell.Value = CDbl(inputVal)

NextCell:
    Next cell

SafeExit:
    If Not Application.EnableEvents Then Application.EnableEvents = True
    Exit Sub

ClearError:
    MsgBox "运行错误：" & Err.Description & "（错误码：" & Err.Number & "）", vbCritical
    Resume SafeExit
End Sub

优化说明 #

• 动态匹配行：根据点击的A列单元格行号，自动定位对应行的C-F列，支持A2-A5所有行的操作
• 金额限制校验：每次录入时计算当前行C-F列的总和，若输入金额导致总和超过B列限额，弹出提示并拒绝录入
• 输入体验优化：输入框显示对应日期表头、已录入总和、剩余可录入金额，方便用户核对；限制输入框仅接受数字，避免非法输入
• 错误处理增强：将错误信息以弹窗形式提示用户，更直观
• 代码可读性提升：使用有意义的常量命名，逻辑分层清晰

内容的提问来源于stack exchange，提问作者Solomom tettey Adamson