如何复制超出范围的数据

Question

我正在尝试复制一些数据，这些数据是我使用两个字符串设置的范围内的列。 范围在“ B”列中设置，我需要将“ C”和“ D”列中的数据复制到该范围的长度，然后将其粘贴到“ B”和“ C”列中的另一张纸中。

通过找到两个字符串“在实施阶段原始项目ER”和“在25原始项目ER”来设置范围。

到目前为止，我已经设法编写了将数据复制到正确位置的代码，但是它仅复制了范围（“ B”列）中的数据

fr = "Originating Project ERs at Implementation Stage"
fc = "Originating Project ERs at 25"
Set r = Worksheets("Sheet1").Cells.Find(What:=fr, LookAt:=xlWhole)
Set c = Worksheets("Sheet1").Cells.Find(What:=fc, LookAt:=xlWhole)

If Not r Is Nothing Then
    StartR = r.Row + 1
        Else: MsgBox fr & " not found"

End If

If Not c Is Nothing Then
    EndR = c.Row - 1
        Else: MsgBox fc & " not found"
End If

If r.Row And c.Row > 1 Then
Worksheets("Sheet1").Range(r, c).Offset(1,1).Copy
Worksheets("PriorityProgress").Range("B2").PasteSpecial Paste:=xlPasteValues
Worksheets("priorityProgress").Range("C2").PasteSpecial Paste:=xlPasteValues

End If`

这是一些示例数据，显示了我想要实现的目标https://i.stack.imgur.com/5csrZ.png

编辑 ：我已经设法使用OffSet 1,1来显示列'C'中的第一组记录，现在只需要'D'

Answer 1

设法通过分别抵消每一列来解决它

 If r.Row And c.Row > 1 Then
    Worksheets("Sheet1").Range(r, c).Offset(1, 1).Copy
    Worksheets("PriorityProgress").Range("B2").PasteSpecial Paste:=xlPasteValues
    Worksheets("Sheet1").Range(r, c).Offset(1, 2).Copy
    Worksheets("priorityProgress").Range("C2").PasteSpecial Paste:=xlPasteValues

Answer 2

这样行吗？

fr = "Originating Project ERs at Implementation Stage"
fc = "Originating Project ERs at 25"
Set r = Worksheets("Sheet1").Cells.Find(What:=fr, LookAt:=xlWhole)
Set c = Worksheets("Sheet1").Cells.Find(What:=fc, LookAt:=xlWhole)

If Not r Is Nothing Then
    StartR = r.Row + 1
        Else: MsgBox fr & " not found"
        Exit Sub
End If

If Not c Is Nothing Then
    EndR = c.Row - 1
        Else: MsgBox fc & " not found"
        Exit Sub
End If

Range(r.Offset(1, 1), c.Offset(-1, 1)).Resize(, 2).Copy
Worksheets("PriorityProgress").Range("B2").PasteSpecial Paste:=xlPasteValues