Copy to Next Row if Value in Specified Row

[MeliKay]

I have a macro written that works. It is currently set to copy the entire row of data based on criteria to another worksheet (25,"A") and then delete that row from the previous worksheet. The reason it is going to Row 25 is because that is the starting row for the information. However, any time that I move more over, it overwrites the previous data. I need it to move additional rows to below the row that has data in it.

Private Sub Worksheet_Change(ByVal Target As Range)


Application.ScreenUpdating = False

' check if value modified in column O
If Target.Column = 15 Then
' ~~~ Call Sub that moves rows from "Travel" worksheet to "Trip Planner" worksheet ~~~
MoveRowsToTripPlanner
End If

Application.ScreenUpdating = True

End Sub



Sub MoveRowsToTripPlanner()

Dim sourceSheet As Worksheet
Dim targetSheet As Worksheet
Dim CopyRng As Range
Dim i As Long, lastRow As Long

' Set the source and target sheets
Set sourceSheet = ThisWorkbook.Worksheets("Travel")
Set targetSheet = ThisWorkbook.Worksheets("Trip Planner")

With sourceSheet
' Find the last row in the source sheet
lastRow = .Cells(.Rows.Count, "O").End(xlUp).Row

' Loop through each row in the source sheet
For i = 2 To lastRow
' Check if cell in column O contains "Trip Planner"
If .Cells(i, "O").Value = "Trip Planner" Then
If CopyRng Is Nothing Then
Set CopyRng = .Cells(i, "O")
Else
Set CopyRng = Application.Union(CopyRng, .Cells(i, "O"))
End If
End If
Next i
End With

' make sure there's at least 1 row that needs to be moved
If Not CopyRng Is Nothing Then
CopyRng.EntireRow.Copy Destination:=targetSheet.Cells(25, "A").End(xlUp).Offset(1)
CopyRng.EntireRow.Delete
End If

End Sub

 

[Joe4]

Welcome to the Board!

Try replacing this part of your code:

' make sure there's at least 1 row that needs to be moved
If Not CopyRng Is Nothing Then
CopyRng.EntireRow.Copy Destination:=targetSheet.Cells(25, "A").End(xlUp).Offset(1)
CopyRng.EntireRow.Delete
End If

with this:
' make sure there's at least 1 row that needs to be moved

Dim lr As Long
If Not CopyRng Is Nothing Then
    lr = targetSheet.Cells(targetSheet.Rows.Count, "A").End(xlUp).Offset(1).Row
    If lr < 25 Then lr = 25
    CopyRng.EntireRow.Copy Destination:=targetSheet.Cells(lr, "A")
    CopyRng.EntireRow.Delete
End If

 

[MeliKay]

Welcome to the Board!

Try replacing this part of your code:

' make sure there's at least 1 row that needs to be moved
If Not CopyRng Is Nothing Then
CopyRng.EntireRow.Copy Destination:=targetSheet.Cells(25, "A").End(xlUp).Offset(1)
CopyRng.EntireRow.Delete
End If

with this:
' make sure there's at least 1 row that needs to be moved

Dim lr As Long
If Not CopyRng Is Nothing Then
    lr = targetSheet.Cells(targetSheet.Rows.Count, "A").End(xlUp).Offset(1).Row
    If lr < 25 Then lr = 25
    CopyRng.EntireRow.Copy Destination:=targetSheet.Cells(lr, "A")
    CopyRng.EntireRow.Delete
End If

@Joe4 You are amazing! Thank you! That worked!!

 

[Joe4]

You are welcome.
Glad I was able to help!