Copy Data once a cell changes and paste within a range on the next empty row

[farley945]

Hi All,

I have the following code to copy the range B:T once column P changes. (only the row the change was on.)

I would then like it to paste within range B5:B44 on a different sheet on the next empty row but currently it only pastes B2:T5 (Starting row is incorrect) and it will keep pasting over those 3 rows only.

Can anyone help me please? I have ten different ranges on the same sheet to paste in the next tab within it's own range but all of them are doing the same starting the paste 3 rows higher and only pasting over the same 3 rows. (Code is the same for each section so only pasted a snippet.)

Thank you in advance

Private Sub Worksheet_Change(ByVal Target As Range)
Dim r As Range
Dim copysheet As Worksheet
Dim Pastesheet As Worksheet

Set copysheet = Worksheets("DH Write Offs")
Set Pastesheet = Worksheets("Written Off")

  Application.ScreenUpdating = False
  
    If Target.Column = 16 And Target.Row >= 5 And Target.Row <= 44 Then
        Set r = Target.Offset(, -14).Resize(, 19)
        copysheet.Range(r.Address).Copy
        Pastesheet.Range("B5:B44").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
        Application.CutCopyMode = False
    End If
End Sub

[#2]

@farley945 

Try this:

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim r As Range
    Dim s As Long
    Dim Pastesheet As Worksheet

    If Not Intersect(Range("P5:P44"), Target) Is Nothing Then
        Set Pastesheet = Worksheets("Written Off")
        s = Pastesheet.Range("B:T").Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
        If s < 4 Then s = 4
        For Each r In Intersect(Range("P5:P44"), Target)
            s = s + 1
            Pastesheet.Range("B" & s).Resize(1, 19).Value = r.Offset(0, -14).Resize(1, 19).Value
        Next r
    End If
End Sub

[#3]

@Hans Vogelaar 

Thank you for the reply but unfortunately it doesn't work

I've attached an example spreadsheet, each section is it's own cost centre (Branch) and must only paste within the corresponding section on the Written Off tab. (All sections are the same size and format across both tabs.)

[#4 · Accepted solution]

@farley945 

There was no way I could have guessed this from your first post...

Here is a new version:

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim i As Long
    Dim r As Range
    Dim s As Long
    Dim Pastesheet As Worksheet

    Set Pastesheet = Worksheets("Written Off")
    For i = 5 To 392 Step 43
        If Not Intersect(Range("P" & i).Resize(40), Target) Is Nothing Then
            s = Pastesheet.Range("P" & i + 40).End(xlUp).Row
            If s < i - 1 Then s = i - 1
            For Each r In Intersect(Range("P" & i).Resize(40), Target)
                s = s + 1
                Pastesheet.Range("B" & s).Resize(1, 19).Value = r.Offset(0, -14).Resize(1, 19).Value
            Next r
        End If
    Next i
End Sub

[#5]

Apologies, I was going to repeat it for each section but yours works perfect thank you :)