Excel VBA遍历行用OFFSET复制多列数据无返回值问题

DevOps 小满

2026-8-26

问题原因

当前代码多列复制无返回结果，是几个隐性逻辑问题叠加导致的：

遍历范围硬编码为11 To 100，没有适配A列动态长度，若"Sales"所在行超出100行会完全匹配不到；如果遍历过程中A列存在错误值（如#N/A、#DIV/0!），值判断语句会直接抛出运行时错误中断代码，之前单列复制时刚好未触发该错误场景，扩展列后触发中断就会表现为无任何结果。
逐次调用Copy + PasteSpecial操作冗余，且如果匹配到多行含"Sales"的记录，后续行会持续覆盖B24/C24/D24的内容，最终结果和预期不符。
值判断未做兼容处理，供应商导出的表格经常存在值前后带不可见空格、大小写不一致的情况，会直接导致匹配失效。
循环变量i定义为Integer类型，若工作表行号超过32767会触发溢出错误。

修复后代码

Sub ImportData()
    Dim FileOpen As Variant
    Dim OpenBook As Workbook
    Dim i As Long, lastRow As Long
    Dim sourceSht As Worksheet, targetSht As Worksheet
    
    Set targetSht = ThisWorkbook.Worksheets("Input")
    Application.ScreenUpdating = False
    
    ' 错误捕获，保证异常时也能恢复屏幕更新
    On Error GoTo ErrorHandler

    FileOpen = Application.GetOpenFilename(Title:="Browse for your File & Import Range", FileFilter:="Excel Files(*.xls*),*xls*")
    If FileOpen = False Then GoTo SafeExit
    
    Set OpenBook = Application.Workbooks.Open(FileOpen)
    Set sourceSht = OpenBook.Sheets(1)
    
    ' 批量替换指定字符
    sourceSht.Range("E11:F100").Replace What:="U", Replacement:=""
    sourceSht.Range("E11:F100").Replace What:="i", Replacement:=""

    ' 直接赋值复制固定区域数据，无需调用剪贴板
    targetSht.Range("B10").Value = sourceSht.Range("E9").Value
    targetSht.Range("B11").Value = sourceSht.Range("E10").Value
    targetSht.Range("C10").Value = sourceSht.Range("F9").Value
    targetSht.Range("C11").Value = sourceSht.Range("F10").Value
    targetSht.Range("D11").Value = sourceSht.Range("B4").Value

    ' 动态获取A列最后一行，适配动态数据范围
    lastRow = sourceSht.Cells(sourceSht.Rows.Count, "A").End(xlUp).Row
    ' 遍历查找目标行
    For i = 11 To lastRow
        ' 先判断单元格是否为错误值，避免比较时触发中断
        If Not IsError(sourceSht.Range("A" & i).Value) Then
            ' 去除前后空格、统一转大写后匹配，兼容导出数据的格式差异
            If UCase(Trim(sourceSht.Range("A" & i).Value)) = "SALES" Then
                targetSht.Range("B24").Value = sourceSht.Range("A" & i).Offset(0, 5).Value
                targetSht.Range("C24").Value = sourceSht.Range("A" & i).Offset(0, 6).Value
                targetSht.Range("D24").Value = sourceSht.Range("A" & i).Offset(0, 2).Value
                ' 匹配到第一个目标行后直接退出循环，避免后续行覆盖已写入数据
                Exit For
            End If
        End If
    Next i

    OpenBook.Close False
SafeExit:
    Application.ScreenUpdating = True
    Exit Sub
ErrorHandler:
    MsgBox "导入出错：" & Err.Description, vbExclamation
    Resume SafeExit
End Sub

关键修改说明

替换逐次Copy + PasteSpecial的写法，直接通过Value属性赋值，避免剪贴板调用导致的异常，执行效率更高。
新增动态行号获取逻辑，通过End(xlUp)获取A列实际最后一行，不再硬编码100行上限，适配供应商表的动态范围。
新增错误值判断：遍历A列时先检查单元格是否为错误类型，避免值比较时触发运行时错误中断流程。
新增匹配兼容逻辑：判断值时通过Trim去除前后不可见空格、UCase统一转大写，避免供应商导出数据的格式差异导致匹配失效。
新增全局错误捕获机制：无论代码正常运行还是抛出异常，都会保证恢复屏幕更新，不会出现Excel界面卡死无响应的问题。
循环变量改为Long类型，避免行号过大时触发溢出错误。
匹配到第一个"Sales"行后直接退出循环，避免多行匹配时后续数据覆盖之前写入的结果；如果需要批量匹配所有"Sales"行，删掉Exit For语句，同时将目标单元格行号改为随循环变量递增即可。

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