修改VBA代码实现跨工作簿而非工作表的数据复制

没问题，把同工作簿的VBA改成跨工作簿操作其实只需要明确工作簿对象的引用，同时确保两个工作簿的访问路径正确就行。我给你整理两种常见的修改方案，你可以根据自己的使用场景选择：

方案1：手动打开两个工作簿时的修改 #

这种情况适合你平时会提前打开源工作簿（包含"Demand Log"工作表）和目标工作簿（包含"Change Log"工作表）的场景，修改后的代码如下：

Sub CopyToChangeLog_CrossWorkbook()
    Dim wbSource As Workbook
    Dim wbTarget As Workbook
    Dim xRg As Range
    Dim xCell As Range
    Dim I As Long
    Dim J As Long
    Dim K As Long
    
    ' 指定源工作簿（当前运行代码的工作簿，即含Demand Log的工作簿）
    Set wbSource = ThisWorkbook
    ' 指定目标工作簿（替换成你实际的目标工作簿文件名，比如"ChangeLogBook.xlsm"）
    Set wbTarget = Workbooks("目标工作簿名称.xlsm")
    
    ' 获取源工作表已用行数
    I = wbSource.Worksheets("Demand Log").UsedRange.Rows.Count
    ' 获取目标工作表B列最后一行的行号
    J = wbTarget.Worksheets("Change Log").Cells(wbTarget.Worksheets("Change Log").Rows.Count, "B").End(xlUp).Row
    
    ' 处理目标工作表为空的情况
    If J = 1 Then
        If Application.WorksheetFunction.CountA(wbTarget.Worksheets("Change Log").UsedRange) = 0 Then J = 0
    End If
    
    ' 设置要检查的源工作表O列范围
    Set xRg = wbSource.Worksheets("Demand Log").Range("O5:O" & I)
    
    Application.ScreenUpdating = False
    For K = xRg.Count To 1 Step -1
        If CStr(xRg(K).Value) = "Change Team" Then
            J = J + 1
            With wbSource.Worksheets("Demand Log")
                ' 复制源行到目标工作表
                Intersect(.Rows(xRg(K).Row), .Range("A:Z")).Copy Destination:=wbTarget.Worksheets("Change Log").Range("A" & J)
                ' 删除源工作表中的该行
                Intersect(.Rows(xRg(K).Row), .Range("A:Z")).Delete xlShiftUp
            End With
        End If
    Next
    Application.ScreenUpdating = True
    
    ' 释放对象
    Set wbSource = Nothing
    Set wbTarget = Nothing
End Sub

关键修改点： #

• 新增了wbSource和wbTarget两个工作簿对象，明确区分源和目标工作簿
• 所有原来的Worksheets("xxx")都替换为wbSource.Worksheets("xxx")或wbTarget.Worksheets("xxx")，避免混淆当前工作簿
• 目标行号的计算逻辑调整为基于目标工作簿的工作表

方案2：自动打开目标工作簿（无需手动打开） #

如果希望代码自动打开目标工作簿，无需提前手动打开，可以使用以下修改后的代码，同时增加了错误处理：

Sub CopyToChangeLog_AutoOpen()
    Dim wbSource As Workbook
    Dim wbTarget As Workbook
    Dim xRg As Range
    Dim xCell As Range
    Dim I As Long
    Dim J As Long
    Dim K As Long
    Dim targetFilePath As String
    
    ' 目标工作簿的完整路径，替换成你实际的文件路径
    targetFilePath = "C:\YourFolder\ChangeLog工作簿.xlsm"
    
    ' 指定源工作簿（当前运行代码的工作簿）
    Set wbSource = ThisWorkbook
    
    ' 尝试打开目标工作簿
    On Error Resume Next
    Set wbTarget = Workbooks.Open(targetFilePath)
    On Error GoTo 0
    
    ' 检查目标工作簿是否成功打开
    If wbTarget Is Nothing Then
        MsgBox "无法找到目标工作簿，请检查路径是否正确！", vbExclamation
        Exit Sub
    End If
    
    ' 获取源工作表已用行数
    I = wbSource.Worksheets("Demand Log").UsedRange.Rows.Count
    ' 获取目标工作表B列最后一行的行号
    J = wbTarget.Worksheets("Change Log").Cells(wbTarget.Worksheets("Change Log").Rows.Count, "B").End(xlUp).Row
    
    ' 处理目标工作表为空的情况
    If J = 1 Then
        If Application.WorksheetFunction.CountA(wbTarget.Worksheets("Change Log").UsedRange) = 0 Then J = 0
    End If
    
    ' 设置要检查的源工作表O列范围
    Set xRg = wbSource.Worksheets("Demand Log").Range("O5:O" & I)
    
    Application.ScreenUpdating = False
    For K = xRg.Count To 1 Step -1
        If CStr(xRg(K).Value) = "Change Team" Then
            J = J + 1
            With wbSource.Worksheets("Demand Log")
                ' 复制源行到目标工作表
                Intersect(.Rows(xRg(K).Row), .Range("A:Z")).Copy Destination:=wbTarget.Worksheets("Change Log").Range("A" & J)
                ' 删除源工作表中的该行
                Intersect(.Rows(xRg(K).Row), .Range("A:Z")).Delete xlShiftUp
            End With
        End If
    Next
    Application.ScreenUpdating = True
    
    ' 可选：保存并关闭目标工作簿（如果不需要保留打开状态，取消下面两行的注释）
    ' wbTarget.Save
    ' wbTarget.Close
    
    ' 释放对象
    Set wbSource = Nothing
    Set wbTarget = Nothing
End Sub

关键修改点： #

• 新增了targetFilePath变量，指定目标工作簿的完整绝对路径
• 增加了错误处理逻辑，避免因文件找不到导致代码崩溃
• 可选添加了保存并关闭目标工作簿的语句，按需启用

注意事项： #

• 确保目标工作簿的"Change Log"工作表列结构和源工作簿的"Demand Log"表一致，否则复制粘贴可能出现格式或内容错位
• 如果使用自动打开方案，路径必须准确，建议使用绝对路径；如果是相对路径，要确保源工作簿和目标工作簿在同一文件夹下
• 代码建议保存到源工作簿（含"Demand Log"的工作簿）中，运行时确保源工作簿处于打开状态

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