VBA复制数据跳过大量空行错位粘贴至数万行问题求助

原代码核心问题 #

1. 循环逻辑错误：遍历D7:D400的每个非空单元格时，每次都会复制整个符合条件的区域，导致同一数据被重复粘贴多次，目标行不断向下偏移，最终出现在几万行的位置。
2. 复制范围语法错误：wsCopy.Range("A8:F400" & lCopyLastRow) 会生成非法的单元格范围（比如A8:F400100），正确的范围应该是从A8到F列最后一行。
3. 目标行判断冗余：每次循环都重新计算目标行，加上重复复制的逻辑，导致粘贴位置不断跳空。
4. 屏幕更新未优化：未关闭屏幕更新，不仅运行慢，还可能导致视觉错乱。

修复后的代码 #

Sub MoveListToIndex()
    Dim wsCopy As Worksheet
    Dim wsDest As Worksheet
    Dim lCopyLastRow As Long
    Dim lDestLastRow As Long
    Dim copyRange As Range
    Dim Answer As VbMsgBoxResult
    
    Answer = MsgBox("Are you sure you want to Submit the List?", vbYesNo, "Submit List")
    If Answer <> vbYes Then Exit Sub
    
    ' 禁用屏幕更新提升效率
    Application.ScreenUpdating = False
    
    ' 定义工作表对象
    Set wsCopy = Worksheets("Single Column")
    Set wsDest = Worksheets("Index")
    
    ' 找到Single Column中D列最后一行数据
    lCopyLastRow = wsCopy.Cells(wsCopy.Rows.Count, "D").End(xlUp).Row
    
    ' 筛选出D列非空的行对应的A:F区域
    With wsCopy.Range("A8:F" & lCopyLastRow)
        .AutoFilter Field:=4, Criteria1:="<>" ' 第4列是D列，筛选非空值
        Set copyRange = .SpecialCells(xlCellTypeVisible)
        .AutoFilter ' 关闭筛选
    End With
    
    ' 找到Index中AA列第一个空行
    lDestLastRow = wsDest.Cells(wsDest.Rows.Count, "AA").End(xlUp).Row
    ' 如果AA列无数据，从第2行开始
    If lDestLastRow < 2 Then lDestLastRow = 2 Else lDestLastRow = lDestLastRow + 1
    
    ' 粘贴值和数字格式
    copyRange.Copy
    wsDest.Range("AA" & lDestLastRow).PasteSpecial xlPasteValuesAndNumberFormats
    
    ' 清除剪贴板，恢复屏幕更新
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
    
    MsgBox "The List has been Successfully Added!"
End Sub

修复说明 #

• 一次性筛选复制：使用AutoFilter筛选D列非空的行，一次性获取需要复制的区域，避免循环重复复制。
• 正确的范围定义：用A8:F" & lCopyLastRow生成合法的复制范围。
• 准确的目标行判断：处理AA列无数据的情况，确保从第2行开始粘贴。
• 优化运行效率：禁用屏幕更新，操作完成后恢复，同时清除剪贴板释放资源。

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