如何修改VBA代码实现跨工作簿复制指定列并新增固定字段

针对你的需求，我调整了代码，实现跨工作簿复制指定列、添加固定字段，同时保留原有的筛选和删除逻辑，代码如下：

Sub CopyDataToTargetWorkbook()
    Dim sourceSheet As Worksheet
    Dim targetWorkbook As Workbook
    Dim targetSheet As Worksheet
    Dim lastRowSource As Long
    Dim lastRowTarget As Long
    Dim i As Long
    Dim a2Value As Variant, b2Value As Variant
    
    ' 绑定源工作表（当前工作簿的Cases表）
    Set sourceSheet = ThisWorkbook.Worksheets("Cases")
    
    ' 提前读取源表A2、B2的固定值
    a2Value = sourceSheet.Range("A2").Value
    b2Value = sourceSheet.Range("B2").Value
    
    ' 打开目标工作簿，请替换为你的实际文件路径
    ' 若目标工作簿已打开，替换为：Set targetWorkbook = Workbooks("目标文件名.xlsx")
    Set targetWorkbook = Workbooks.Open("C:\示例路径\目标工作簿.xlsx")
    ' 绑定目标工作表
    Set targetSheet = targetWorkbook.Worksheets("Tire Cases")
    
    ' 获取源表X列最后一行数据行号
    lastRowSource = sourceSheet.Cells(sourceSheet.Rows.Count, "X").End(xlUp).Row
    
    ' 从下往上循环处理，避免删除行后索引混乱
    For i = lastRowSource To 2 Step -1
        ' 筛选X列值为"TIRES"的行
        If sourceSheet.Cells(i, "X").Value = "TIRES" Then
            ' 找到目标表C列最后一行的下一行，作为插入位置
            lastRowTarget = targetSheet.Cells(targetSheet.Rows.Count, "C").End(xlUp).Row + 1
            
            ' 复制源表当前行的C-F列到目标表对应位置
            sourceSheet.Range("C" & i & ":F" & i).Copy Destination:=targetSheet.Range("C" & lastRowTarget)
            
            ' 将A2、B2的值写入目标表的A、B列
            targetSheet.Range("A" & lastRowTarget).Value = a2Value
            targetSheet.Range("B" & lastRowTarget).Value = b2Value
            
            ' 删除源表当前行
            sourceSheet.Rows(i).Delete
        End If
    Next i
    
    ' 保存并关闭目标工作簿（不需要自动保存可注释这两行）
    targetWorkbook.Save
    targetWorkbook.Close
    
    ' 释放对象，避免内存占用
    Set targetSheet = Nothing
    Set targetWorkbook = Nothing
    Set sourceSheet = Nothing
    
    MsgBox "数据复制完成！"
End Sub

关键修改点说明 #

• 跨工作簿支持：新增targetWorkbook对象，通过Workbooks.Open指定目标文件路径，适配你"另一个工作簿"的需求。
• 精准复制指定列：替换原整行复制逻辑，只复制源表C-F列到目标表对应列。
• 添加固定字段：提前读取A2、B2的值，循环中直接写入目标表的A、B列，避免重复读取单元格提升效率。
• 优化循环逻辑：改为从下往上循环（Step -1），避免删除行后后续行索引错位，比原代码的i=i-1更稳定。

新手注意事项 #

1. 务必替换代码中的目标工作簿路径和工作表名称为你的实际信息。
2. 如果目标工作簿已经打开，注释掉Workbooks.Open那一行，改用Set targetWorkbook = Workbooks("你的目标文件名.xlsx")。
3. 测试阶段可以先注释掉sourceSheet.Rows(i).Delete，确认复制数据正确后再开启删除功能。

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