如何复制指定范围对应的多列数据？VBA代码优化求助

嘿，我看你现在的代码只能复制C列的数据，问题出在你选中的范围只覆盖了C列，咱们调整一下就能同时把D列也复制过去，完美匹配你要的需求！

问题分析 #

你原来的代码里，Range(r, c).Offset(1,1) 其实只选中了C列的对应行（因为r和c是B列的单元格，偏移1列就是C列），所以自然只能复制C列的数据。要同时复制C、D列，咱们得直接选中这两列的目标范围。

修正后的完整代码 #

Sub CopyCDtoPriorityProgress()
    Dim fr As String, fc As String
    Dim r As Range, c As Range
    Dim StartR As Long, EndR As Long
    
    ' 定义定位字符串
    fr = "Originating Project ERs at Implementation Stage"
    fc = "Originating Project ERs at 25"
    
    ' 在Sheet1中查找起始和结束标记
    Set r = Worksheets("Sheet1").Cells.Find(What:=fr, LookAt:=xlWhole)
    Set c = Worksheets("Sheet1").Cells.Find(What:=fc, LookAt:=xlWhole)
    
    ' 检查标记是否找到
    If r Is Nothing Then
        MsgBox fr & " not found"
        Exit Sub
    End If
    If c Is Nothing Then
        MsgBox fc & " not found"
        Exit Sub
    End If
    
    ' 计算要复制的行范围（起始行是标记行+1，结束行是结束标记行-1）
    StartR = r.Row + 1
    EndR = c.Row - 1
    
    ' 确保起始行小于结束行（避免无效范围）
    If StartR < EndR Then
        ' 直接选中Sheet1中C列到D列的目标行范围
        Worksheets("Sheet1").Range("C" & StartR & ":D" & EndR).Copy
        ' 粘贴到PriorityProgress的B2开始的位置（B列对应C列数据，C列对应D列数据）
        Worksheets("PriorityProgress").Range("B2").PasteSpecial Paste:=xlPasteValues
    Else
        MsgBox "No valid rows to copy between the two markers!"
    End If
    
    ' 清除剪贴板，避免残留
    Application.CutCopyMode = False
End Sub

关键修改点 #

• 精准选中多列范围：直接用Range("C" & StartR & ":D" & EndR)选中Sheet1中需要复制的C、D列区域，不用再依赖Offset偏移
• 简化粘贴操作：一次复制多列，粘贴到目标工作表的B2位置，会自动把C列数据放到B2开始，D列数据放到C2开始，完全匹配你的需求
• 增加有效性判断：加了StartR < EndR的判断，避免两个标记顺序颠倒或者中间没有行的情况弹出提示
• 优化代码结构：拆分了判断逻辑，让代码更易读，还加了剪贴板清理的步骤

这样修改后，就能完美实现你要的功能啦！

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