VBA循环提取非连续列值至另一工作表的问题求助

你在处理非连续列的复制粘贴时遇到的核心问题，在于原代码里Range(Cells(i, 7), Cells(i, 16), Cells(i, 26))的写法错误——Range对象不支持直接传入多个离散的Cells参数来选中非连续单元格。另外根据你的描述，你需要检查的是第16列（P列）的空值，而非原代码里的第2列（B列），这一点也需要调整。

下面是修正后的代码，完美实现你的需求：

Sub CopyNonContinuousColumns()
    Application.ScreenUpdating = False
    
    Dim wsData As Worksheet, wsDest As Worksheet
    Dim lr As Long, i As Long
    Dim destRow As Long
    
    ' 定义工作表对象，避免使用Select/Activate（更高效稳定）
    Set wsData = ThisWorkbook.Sheets("DATA")
    Set wsDest = ThisWorkbook.Sheets("Sheet2")
    
    ' 获取DATA表中P列的最后一行（匹配你检查第16列的需求）
    lr = wsData.Range("P" & wsData.Rows.Count).End(xlUp).Row
    ' 获取Sheet2中A列的最后一行，确定粘贴起始位置
    destRow = wsDest.Range("A" & wsDest.Rows.Count).End(xlUp).Row + 1
    
    For i = 3 To lr
        ' 检查第16列（P列）是否非空
        If wsData.Cells(i, 16).Value <> "" Then
            ' 直接赋值仅传递值，不携带格式，高效简洁
            wsDest.Cells(destRow, 1).Value = wsData.Cells(i, 7).Value  ' G列对应目标A列
            wsDest.Cells(destRow, 2).Value = wsData.Cells(i, 16).Value ' P列对应目标B列
            wsDest.Cells(destRow, 3).Value = wsData.Cells(i, 26).Value ' Z列对应目标C列
            destRow = destRow + 1 ' 目标行下移，准备下一行数据
        End If
    Next i
    
    Application.ScreenUpdating = True
    MsgBox "数据复制完成！", vbInformation
End Sub

关键改进点： #

• 摒弃Select/Activate操作：直接使用工作表对象操作，比反复选中工作表更高效，也避免了因工作表切换导致的意外错误。
• 正确处理非连续列：针对仅3列的场景，直接逐个单元格赋值是最简洁高效的方式，完全满足仅传值的需求。
• 修正检查条件：按照你的需求调整为检查第16列（P列）的空值，匹配你描述的逻辑。
• 仅传递值：通过.Value直接赋值，不会携带任何单元格格式，比Copy/PasteSpecial的方式性能更优。
• 优化目标行管理：提前计算目标表的起始行，每次复制后直接下移，避免循环中重复查找最后一行，提升运行效率。

如果后续需要处理更多非连续列，也可以用Union合并单元格后再粘贴值，代码示例如下：

Sub CopyNonContinuousColumns_Union()
    Application.ScreenUpdating = False
    
    Dim wsData As Worksheet, wsDest As Worksheet
    Dim lr As Long, i As Long
    Dim destRange As Range
    
    Set wsData = ThisWorkbook.Sheets("DATA")
    Set wsDest = ThisWorkbook.Sheets("Sheet2")
    
    lr = wsData.Range("P" & wsData.Rows.Count).End(xlUp).Row
    
    For i = 3 To lr
        If wsData.Cells(i, 16).Value <> "" Then
            ' 合并非连续单元格
            Union(wsData.Cells(i, 7), wsData.Cells(i, 16), wsData.Cells(i, 26)).Copy
            ' 获取目标表的下一个空行
            Set destRange = wsDest.Range("A" & wsDest.Rows.Count).End(xlUp).Offset(1, 0)
            ' 仅粘贴值
            destRange.PasteSpecial xlPasteValues
            Application.CutCopyMode = False ' 清除复制状态，避免内存占用
        End If
    Next i
    
    Application.ScreenUpdating = True
    MsgBox "数据复制完成！", vbInformation
End Sub

两种方式都能解决你的问题，第一种直接赋值的方式性能更优，适合列数少的场景；第二种Union的方式更灵活，适合后续扩展列数的情况。

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