如何復制超出范圍的數據

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