VBA实现遍历列触发工作簿选择跨工作簿复制粘贴数据求助

原代码核心问题 #

• 执行顺序错误：未打开工作簿就尝试引用其中的工作表，会触发下标越界报错
• 粘贴位置逻辑不合理：硬编码每次偏移55行，未动态读取目标表已用区域最后一行，也未满足间隔1行的可读性需求
• 工作表名称不符合需求：使用测试用的Sheet4、Sheet6，未替换为要求的Calculated Split Times和目标表
• 触发单元格定位不准确：原prmpt过程中用ActiveCell取值，多选修改时无法对应到实际触发的单元格

修正后完整代码 #

工作表事件代码 #

需放在"Weekly Staff Production"工作表的代码模块中

Sub Worksheet_Change(ByVal Target As Range)
    Dim Cell As Range
    ' 仅判断D列的修改
    If Not Intersect(Target, Me.Columns("D")) Is Nothing Then
        Application.EnableEvents = False ' 防止粘贴过程触发事件死循环
        For Each Cell In Intersect(Target, Me.Columns("D"))
            If Cell.Value = "Coord Issue" Then
                ' 将触发单元格的行号传入prmpt过程，避免ActiveCell定位错误
                Call prmpt(Cell.Row)
            End If
        Next Cell
        Application.EnableEvents = True
    End If
End Sub

数据导入逻辑代码 #

可放在同一工作表模块或标准模块中

Sub prmpt(triggerRow As Long)
    Dim i As Integer
    Dim wbSource As Workbook
    Dim wsCopy As Worksheet
    Dim wsDest As Worksheet
    Dim lDestLastRow As Long
    Dim issue_asset As Variant
    
    ' 读取触发行B列的资产信息
    issue_asset = ThisWorkbook.Worksheets("Weekly Staff Production").Cells(triggerRow, 2).Value
    MsgBox "Select intersections affected by " & issue_asset, vbInformation, "Hossam"
    
    ' 初始化目标工作表，请将括号内的表名替换为你实际存放粘贴数据的工作表名称
    Set wsDest = ThisWorkbook.Worksheets("主")
    
    ' 打开文件选择对话框
    With Application.FileDialog(msoFileDialogFilePicker)
        .AllowMultiSelect = True
        .Filters.Clear
        .Filters.Add "Excel Files", "*.xls*"
        
        If .Show = True Then
            Application.ScreenUpdating = False ' 关闭屏幕更新提升运行速度
            For i = 1 To .SelectedItems.Count
                ' 先打开选中的源工作簿
                Set wbSource = Workbooks.Open(.SelectedItems(i))
                ' 绑定源数据工作表
                Set wsCopy = wbSource.Worksheets("Calculated Split Times")
                
                ' 动态计算目标表粘贴起始行：已用区域最后一行+2，实现两次粘贴间隔1行
                lDestLastRow = wsDest.Cells(wsDest.Rows.Count, "A").End(xlUp).Row + 2
                
                ' 复制指定区域数据，若不需要保留源格式仅要数值，可替换为下方注释的代码
                wsCopy.Range("A14:U54").Copy wsDest.Range("A" & lDestLastRow)
                ' 仅粘贴值写法：wsCopy.Range("A14:U54").Copy : wsDest.Range("A" & lDestLastRow).PasteSpecial xlPasteValues
                
                ' 关闭源工作簿，不保存修改
                wbSource.Close SaveChanges:=False
            Next i
            Application.ScreenUpdating = True
            MsgBox "数据导入完成", vbInformation
        End If
    End With
End Sub

使用注意事项 #

• 代码中Set wsDest = ThisWorkbook.Worksheets("主") 请将括号内的表名替换为你实际存放粘贴数据的工作表名称
• 如果不需要保留源格式仅要数值，可以将复制粘贴代码替换为注释中仅粘贴值的写法，运行速度更快
• 代码已添加事件关闭和屏幕更新关闭逻辑，避免重复触发和运行卡顿

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