如何修复VBA遍历单元格匹配值后复制上下行内容错位的问题

• 上下行偏移逻辑写反：上一行（匹配行的前一行）对应Offset(-1, 0)，应该写入B列的Above Values，原代码赋值给了C列；下一行（匹配行的后一行）对应Offset(1, 0)，应该写入C列的Below Values，原代码赋值给了B列。
• 复制范围错误：Range(Filter.Offset(1, 0), Filter.Offset(0, 0))会选中从匹配行到下一行的两行内容，你只需要单个单元格的值，不需要选中范围，且单列场景下xlToLeft、xlToRight操作完全多余。
• 粘贴位置计算逻辑冗余且容易错位：不需要分别给三列找最后一行，只要找到A列最后一行的新行，同一行的B、C列就是对应的粘贴位置，避免某列出现空值时定位错位。
• 没有限定工作表：代码中裸写的Range默认取当前活动工作表的内容，如果你运行时不是停留在Sheet1，会取值错误。
• 缺少边界判断：如果匹配到第一行或者最后一行的内容，偏移取上下行会报错，需要增加边界判断避免异常。

Sub CopyRecords()
    Dim FilterCol As Range
    Dim Filter As Range
    Dim nextRow As Long
    Dim srcSht As Worksheet, destSht As Worksheet
    
    ' 提前定义工作表，避免后续重复写路径
    Set srcSht = ThisWorkbook.Sheets(1)
    Set destSht = ThisWorkbook.Sheets(2)
    
    ' 清空目标表历史数据
    destSht.Range("A2:C" & destSht.Rows.Count).Clear
    
    ' 自动读取源表A列所有有内容的行
    Set FilterCol = srcSht.Range("A1:A" & srcSht.Cells(srcSht.Rows.Count, "A").End(xlUp).Row)
    
    ' 目标表起始写入行
    nextRow = 2
    
    For Each Filter In FilterCol
        ' 匹配规则可按需修改
        If Left(Filter.Value, 5) = "Testo" Then
            ' 边界判断：避免匹配到第一行/最后一行时报错
            If Filter.Row > 1 And Filter.Row < FilterCol.Rows.Count Then
                ' 直接赋值效率比复制粘贴更高
                destSht.Cells(nextRow, "A") = Filter.Value
                destSht.Cells(nextRow, "B") = Filter.Offset(-1, 0).Value
                destSht.Cells(nextRow, "C") = Filter.Offset(1, 0).Value
                ' 写入后行号+1
                nextRow = nextRow + 1
            End If
        End If
    Next Filter
End Sub

Excel单工作表最大支持1048576行，你提到的十亿行CSV无法直接用Excel完整加载处理，建议用Python的pandas库完成该需求，处理大文件效率和稳定性远高于VBA。

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