VBA按条件从指定路径工作簿复制数据的技术求助

首先，咱们先梳理原代码里的几个核心问题，这些问题直接导致匹配逻辑失效且运行效率低下：

• 变量类型错误：SourceWBpath被定义为Variant但直接赋值了Range对象，应该取单元格的文本值
• 循环逻辑混乱：每次循环都重复打开/关闭源工作簿，严重拖慢效率
• 匹配条件错误：既没有正确提取源单元格前18字符，也搞反了匹配判断逻辑
• 变量未声明：endRow、SourceWB等变量没有声明，容易引发隐性错误
• 单元格取值错误：strCellValue.Value2的写法完全不对，没有指定具体单元格

下面是修正后的完整代码，完全符合你的需求：

Option Explicit

Sub Copy_Data()
    Dim sourceWBPath As String
    Dim sourceWB As Workbook
    Dim targetWS As Worksheet
    Dim definedNameValue As String
    Dim lastRowSource As Long
    Dim i As Long
    Dim nextRowTarget As Long
    
    ' 关闭屏幕更新提升运行速度
    Application.ScreenUpdating = False
    
    ' 初始化对象和变量
    Set targetWS = ThisWorkbook.Worksheets("Test")
    sourceWBPath = targetWS.Range("E1").Value ' 从Test表E1获取源工作簿路径
    definedNameValue = ThisWorkbook.Names("MyDefinedName").RefersToRange.Value ' 获取当前工作簿的Defined Name值
    
    ' 检查路径是否为空
    If sourceWBPath = "" Then
        MsgBox "源工作簿路径不能为空！", vbExclamation
        Application.ScreenUpdating = True
        Exit Sub
    End If
    
    ' 打开源工作簿（只读模式避免锁定）
    On Error Resume Next
    Set sourceWB = Workbooks.Open(sourceWBPath, ReadOnly:=True, Local:=True)
    On Error GoTo 0
    
    ' 检查源工作簿是否成功打开
    If sourceWB Is Nothing Then
        MsgBox "无法打开指定路径的工作簿，请检查路径是否正确！", vbCritical
        Application.ScreenUpdating = True
        Exit Sub
    End If
    
    ' 获取源工作簿Sheet1的N列最后一行
    lastRowSource = sourceWB.Worksheets("Sheet1").Cells(sourceWB.Worksheets("Sheet1").Rows.Count, "N").End(xlUp).Row
    
    ' 获取目标工作表Test的下一个空行（从A列判断）
    nextRowTarget = targetWS.Cells(targetWS.Rows.Count, "A").End(xlUp).Row + 1
    
    ' 遍历源工作簿Sheet1的N列数据（从第5行开始，和原代码保持一致）
    For i = 5 To lastRowSource
        Dim sourceCellValue As String
        sourceCellValue = sourceWB.Worksheets("Sheet1").Cells(i, "N").Value
        
        ' 核心匹配逻辑：源单元格前18字符和Defined Name完全匹配
        If Left(sourceCellValue, 18) = definedNameValue Then
            ' 复制当前行的A-Y列到目标工作表的下一行
            sourceWB.Worksheets("Sheet1").Range("A" & i & ":Y" & i).Copy
            targetWS.Range("A" & nextRowTarget).PasteSpecial xlPasteValues
            nextRowTarget = nextRowTarget + 1 ' 目标行下移
        End If
    Next i
    
    ' 清理操作
    Application.CutCopyMode = False
    sourceWB.Close SaveChanges:=False ' 关闭源工作簿不保存
    Application.ScreenUpdating = True
    
    MsgBox "数据提取完成！", vbInformation
End Sub

关键修改点说明： #

• Option Explicit：强制所有变量必须声明，避免因拼写错误导致的隐性bug
• 路径处理：正确从Test!E1提取文本路径，增加空路径和打开失败的错误提示
• 匹配逻辑：明确使用Left(sourceCellValue, 18)提取源N列单元格的前18个字符，和当前工作簿的MyDefinedName值做精确匹配
• 效率优化：只打开一次源工作簿，遍历完成后再关闭，避免重复IO操作
• 动态行处理：自动获取源工作簿N列的最后一行，以及目标工作表的下一个空行，避免硬编码行号导致的数据遗漏或覆盖
• 错误处理：增加源工作簿打开失败的判断，提升代码健壮性

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