VBA宏语法错误求助：提取指定列数据至目标工作表

需求与问题概述 #

需要实现的VBA宏功能：

• 弹出对话框让用户选择源数据工作簿
• 提取该工作簿中D、I列含数字的单元格，以及其左侧C、H列的文本内容
• 将符合条件的数据粘贴到包含宏的「Master Tracker」工作簿「Data」工作表的AT、AU列（从AT2开始）

当前代码在Set copyrng = (sell:selloff)处触发语法错误，无法正常运行。

原代码问题分析 #

1. Range引用语法错误：(sell:selloff)不是合法的VBA Range引用方式，且原代码中Offset(-1,0)是向上偏移一行，逻辑错误（应取左侧列，即Offset(0,-1)）
2. 文件处理逻辑错误：用户选择的是单个文件，原代码误将文件路径当作文件夹路径，用Dir遍历文件会导致错误
3. 功能缺失：未实现I列数据的提取逻辑，仅处理了D列
4. 目标区域定位错误：Range("AT2" & Rows.Count)写法错误，无法正确找到AT列的最后一行
5. 效率低下：遍历整列Range("D:D")会大幅降低运行速度，应仅遍历有数据的行
6. 隐式引用风险：未显式指定工作表，依赖激活状态易引发错误

修正后的完整代码 #

Sub ImportData()
    Dim sourceWB As Workbook
    Dim sourceWS As Worksheet
    Dim fldr As FileDialog
    Dim message As String: message = "Would you like to import new data?"
    Dim ans As VbMsgBoxResult
    Dim targetWS As Worksheet
    Dim lastRow As Long
    Dim i As Long
    Dim targetRow As Long
    
    ' 禁用屏幕更新提升速度
    Application.ScreenUpdating = False
    
    ' 确认是否导入数据
    ans = MsgBox(message, vbYesNo)
    If ans <> vbYes Then GoTo Cleanup
    
    ' 选择源数据工作簿
    Set fldr = Application.FileDialog(msoFileDialogFilePicker)
    With fldr
        .Title = "Select Source Data Workbook"
        .AllowMultiSelect = False
        .Filters.Add "Excel Files", "*.xlsx;*.xls"
        If .Show <> -1 Then
            MsgBox "No file selected. Operation cancelled."
            GoTo Cleanup
        End If
    End With
    
    ' 打开选中的源工作簿
    Set sourceWB = Workbooks.Open(Filename:=fldr.SelectedItems(1), ReadOnly:=True)
    ' 默认取源工作簿的第一个工作表，可根据实际修改
    Set sourceWS = sourceWB.Sheets(1)
    
    ' 定位目标工作表
    Set targetWS = ThisWorkbook.Sheets("Data")
    ' 获取AT列最后一行，确定粘贴起始行
    targetRow = targetWS.Cells(targetWS.Rows.Count, "AT").End(xlUp).Row
    If targetRow < 2 Then targetRow = 2 ' 确保从AT2开始
    
    ' 处理D列（对应C列文本+D列数字）
    lastRow = sourceWS.Cells(sourceWS.Rows.Count, "D").End(xlUp).Row
    For i = 1 To lastRow
        If IsNumeric(sourceWS.Cells(i, "D").Value) Then
            ' 复制C、D列数据到目标AT、AU列
            targetWS.Cells(targetRow, "AT").Value = sourceWS.Cells(i, "C").Value
            targetWS.Cells(targetRow, "AU").Value = sourceWS.Cells(i, "D").Value
            targetRow = targetRow + 1
        End If
    Next i
    
    ' 处理I列（对应H列文本+I列数字）
    lastRow = sourceWS.Cells(sourceWS.Rows.Count, "I").End(xlUp).Row
    For i = 1 To lastRow
        If IsNumeric(sourceWS.Cells(i, "I").Value) Then
            ' 复制H、I列数据到目标AT、AU列
            targetWS.Cells(targetRow, "AT").Value = sourceWS.Cells(i, "H").Value
            targetWS.Cells(targetRow, "AU").Value = sourceWS.Cells(i, "I").Value
            targetRow = targetRow + 1
        End If
    Next i
    
    ' 关闭源工作簿
    sourceWB.Close SaveChanges:=False
    MsgBox "Data imported successfully!"
    
Cleanup:
    Application.ScreenUpdating = True
End Sub

关键改动说明 #

• 修正Range引用与逻辑：移除错误的(sell:selloff)写法，直接通过单元格坐标提取C/D、H/I列对应数据，避免Range复制的冗余操作
• 修复文件选择逻辑：直接打开用户选中的单个文件，取消错误的Dir遍历逻辑
• 补充I列处理：新增I列的遍历判断，完整实现需求中的两列数据提取
• 优化目标区域定位：正确计算AT列的最后一行，确保从AT2开始粘贴
• 提升运行效率：仅遍历源工作表中有数据的行，减少循环次数
• 显式对象引用：全程通过工作表对象操作，避免依赖激活状态，降低错误风险

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