请求编写Excel VBA脚本：按规则跨工作表复制动态列表数据

快速上手步骤 #

1. 打开你的Excel文件，按下Alt + F11打开VBA编辑器
2. 在左侧工程资源管理器中，找到当前工作簿，右键选择「插入」→「模块」
3. 将下方的VBA代码粘贴到新模块中
4. 返回Excel，通过按钮或下拉列表触发脚本执行

VBA代码 #

Sub 复制啤酒数据()
    Dim ws As Worksheet
    Dim targetWs As Worksheet
    Dim i As Integer
    Dim lastRow As Integer
    
    ' 指定包含动态列表的工作表（当前激活表）
    Set ws = ThisWorkbook.ActiveSheet
    
    ' 遍历I2到I15的行
    For i = 2 To 15
        ' 若I列当前行为空白，立即停止循环
        If ws.Cells(i, "I").Value = "" Then Exit For
        
        ' 尝试获取目标工作表
        On Error Resume Next
        Set targetWs = ThisWorkbook.Worksheets(ws.Cells(i, "I").Value)
        On Error GoTo 0
        
        ' 如果目标工作表存在，执行复制操作
        If Not targetWs Is Nothing Then
            ' 找到目标工作表A列最后一行的下一个空白行
            lastRow = targetWs.Cells(targetWs.Rows.Count, "A").End(xlUp).Row + 1
            ' 将J列数据复制到目标位置
            targetWs.Cells(lastRow, "A").Value = ws.Cells(i, "J").Value
        End If
        
        ' 重置变量，避免下一次循环出错
        Set targetWs = Nothing
    Next i
End Sub

代码说明 #

• ThisWorkbook：确保脚本仅操作当前打开的工作簿，避免误操作其他文件
• 循环终止逻辑：遍历到I列空白单元格时立即停止，符合动态列表的需求
• 错误处理：通过On Error Resume Next捕获「目标工作表不存在」的情况，防止脚本崩溃
• 空白行定位：End(xlUp)会从A列底部向上找最后一个有数据的行，+1就是下一个可粘贴的空白行

触发脚本的两种方式 #

方式1：手动按钮触发 #

1. 点击「开发工具」→「插入」→「表单控件（按钮）」
2. 在工作表上画出按钮，释放鼠标后选择复制啤酒数据宏
3. 以后点击这个按钮就能执行数据复制

方式2：下拉列表选择后自动触发 #

1. 右键点击包含下拉列表的工作表标签，选择「查看代码」
2. 将下方代码粘贴到工作表代码窗口中（注意修改下拉列表的单元格地址）

Private Sub Worksheet_Change(ByVal Target As Range)
    ' 将$B$1改成你的下拉列表实际所在单元格地址
    If Target.Address = "$B$1" Then
        Call 复制啤酒数据
    End If
End Sub

内容的提问来源于stack exchange，提问作者Jeff Parten