如何修改Excel VBA脚本，基于特定标识选取目标数据？

直接上可满足需求的完整代码，替换你现有的Import_File过程：

Sub Import_File()
    Dim ws As Worksheet
    Dim lastRow As Long, targetRow As Long
    Dim searchRange As Range, foundCell As Range
    Dim searchValues As Variant
    Dim dataStartRow As Long, dataEndRow As Long
    Dim dataRange As Range, lastCol As Long
    
    ' 设置目标工作表（根据实际需求修改）
    Set ws = ThisWorkbook.ActiveSheet
    
    ' 获取工作表最后一行
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    
    ' 定义要查找的标识值
    searchValues = Array("n", "Calibration")
    targetRow = 0
    
    ' 从最后一行向上查找标识
    Set searchRange = ws.Range("A1:A" & lastRow)
    For Each val In searchValues
        Set foundCell = searchRange.Find(What:=val, After:=ws.Cells(1, "A"), _
            LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, _
            SearchDirection:=xlPrevious, MatchCase:=False)
        
        If Not foundCell Is Nothing Then
            targetRow = foundCell.Row
            Exit For
        End If
    Next val
    
    ' 未找到标识的处理
    If targetRow = 0 Then
        MsgBox "未找到指定标识行，请检查数据！"
        Exit Sub
    End If
    
    ' 计算数据范围的起止行
    dataStartRow = targetRow - 8
    dataEndRow = targetRow - 1
    
    ' 防止起始行超出合法范围
    If dataStartRow < 1 Then
        MsgBox "标识行上方不足8行数据，请检查！"
        Exit Sub
    End If
    
    ' 动态获取数据列范围（适配新增列）
    lastCol = ws.Cells(dataStartRow, ws.Columns.Count).End(xlToLeft).Column
    Set dataRange = ws.Range(ws.Cells(dataStartRow, 1), ws.Cells(dataEndRow, lastCol))
    
    ' 执行复制操作（可根据需求修改粘贴目标）
    dataRange.Copy
    ' 示例：粘贴到Sheet2的A1单元格
    ' ThisWorkbook.Sheets("Sheet2").Range("A1").PasteSpecial xlPasteValues
    
    ' 清除剪贴板
    Application.CutCopyMode = False
End Sub

关键逻辑与问题排查 #

• 动态标识查找：从工作表底部向上搜索，同时支持两个标识值，找到即停止，避免匹配上方无关数据
• 适配新增列：通过End(xlToLeft)自动获取数据行的最后一列，无需固定列范围
• 边界防护：加入标识未找到、数据行数不足的判断，避免运行报错
• 原代码失效原因：你之前的查找逻辑大概率是这几个问题导致的：
  • 没设置SearchDirection:=xlPrevious，导致从顶部往下查找而非从底部向上
  • LookAt参数用了xlPart，匹配到包含关键字的单元格而非完全匹配的标识行
  • 未处理多标识的循环查找，只搜索了其中一个值

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