基于首页下拉菜单的教会Excel预算表数据跨表转移需求

我正在为教会制作Excel预算表，用于记录各类捐款金额并生成月度/季度报表。目前团队每周会录入什一奉献及指定类别的捐款，基础表格已搭建完成，现需增设首页用于信息录入，验证后将数据发送至对应工作表。

当前Home工作表的B2:J3为录入区：第2行是表头，第3行是数据；B3为月份下拉选择框，C3通过VLOOKUP基于月份生成表格范围，D3为目标工作表名称的下拉选择框。

具体需求：

• 将E3:I3区域（日期、描述、来源、指定用途、金额）发送至目标工作表的下一行可用行
• 以J3作为触发单元格（如设置为确认类下拉选项）
• 完成数据发送后，清空F3:J3区域以便下次录入

现有代码如下：

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Column = 8 And Target.Row = 3 Then
Sub Worksheet_ChangeByVal()
    Dim SourceSheet As Worksheet
    Dim DestSheet   As Worksheet
    Dim CopyRange   As Range
    Dim PasteRange  As Range
    
    ' Set the source and destination worksheets
    Set SourceSheet = ThisWorkbook.Worksheets("Home")
    Set DestSheet = ThisWorkbook.Worksheets("Home")
    ' Check if the change was made in the dropdown cell
    ' Set the range to copy
    Set CopyRange = SourceSheet.Range("C3:g3")
    
    ' Set the range to paste
    Set PasteRange = DestSheet.Range("f5:j5")
    
    ' Copy and paste the data
    CopyRange.Copy
    PasteRange.PasteSpecial Paste:=xlPasteValues
End Sub
Sub deletemacro()
    Range("e3:j3").ClearContents
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
    ' 触发条件：仅当J3单元格被修改时执行（可将J3设为"确认录入"类下拉选项）
    If Not Intersect(Target, Me.Range("J3")) Is Nothing Then
        Dim SourceSheet As Worksheet
        Dim DestSheet As Worksheet
        Dim LastRow As Long
        Dim CopyRange As Range
        
        ' 定义源工作表为当前Home表
        Set SourceSheet = Me
        ' 从D3获取目标工作表名称，同时校验工作表是否存在
        On Error Resume Next
        Set DestSheet = ThisWorkbook.Worksheets(SourceSheet.Range("D3").Value)
        On Error GoTo 0
        
        ' 校验逻辑：目标工作表不存在则提示
        If DestSheet Is Nothing Then
            MsgBox "目标工作表不存在，请检查D3的选择！", vbExclamation
            Exit Sub
        End If
        ' 校验必填项：日期和金额为空则提示
        If SourceSheet.Range("E3").Value = "" Or SourceSheet.Range("I3").Value = "" Then
            MsgBox "日期和金额为必填项，请补充完整！", vbExclamation
            Exit Sub
        End If
        
        ' 定义要复制的区域：E3至I3
        Set CopyRange = SourceSheet.Range("E3:I3")
        ' 定位目标工作表的最后一行可用行
        LastRow = DestSheet.Cells(DestSheet.Rows.Count, "A").End(xlUp).Row + 1
        
        ' 粘贴数据至目标工作表的空白行
        CopyRange.Copy
        DestSheet.Cells(LastRow, "A").PasteSpecial Paste:=xlPasteValues
        Application.CutCopyMode = False ' 清除复制状态
        
        ' 清空指定区域并定位光标到E3，方便下次录入
        SourceSheet.Range("F3:J3").ClearContents
        SourceSheet.Range("E3").Select
    End If
End Sub

关键修改说明 #

• 修复原代码语法错误：原代码存在嵌套Sub的问题，现整合为单个Worksheet_Change事件过程，以J3为触发节点
• 动态定位目标工作表：通过D3的下拉值匹配目标表，增加工作表存在性校验
• 自动追加空白行：使用End(xlUp)定位目标表数据区域的最后一行，确保数据不会覆盖现有内容
• 增加数据校验：检查日期、金额等必填项，避免无效数据录入
• 优化操作体验：完成录入后自动清空指定区域，光标回到录入起始位

内容的提问来源于stack exchange，提问作者Jack Tucker