I want the row I copy into new sheet to stay in original sheet as well (script)

[runeroan]

Hi, this script copy the entire row into another sheet based on text value in a cell. Copy works fine.
However it also delete the row copied from original sheet, and I need it to stay! I need the row to stay and be copied, not copied and deleted. How can I get rid of line "Cell.EntireRow.Delete" as this does the delete? If I remove the line I get error. Please help. Thanks.


Sub Kopiere_til_I_produksjon()
Lastrow = Worksheets("Hertz").UsedRange.Rows.Count
lastrow2 = Worksheets("I_produksjon").UsedRange.Rows.Count
If lastrow2 = 1 Then
lastrow2 = 0
Else
End If
Do While Application.WorksheetFunction.CountIf(Range("D:D"), "Innlevert") > 0
Set Check = Range("D1:D" & Lastrow)
For Each Cell In Check
If Cell = "Innlevert" Then
Cell.EntireRow.Copy Destination:=Worksheets("I_produksjon").Range("A" & lastrow2 + 1)
Cell.EntireRow.Delete
lastrow2 = lastrow2 + 1
Else:
End If
Next
Loop
End Sub

 

[My Aswer Is This]

Remove this line of code:

Cell.EntireRow.Delete

 

[runeroan]

Thank you for reply.
I tried to remove line, only gives me error.
Have you tested script without the line?

 

[My Aswer Is This]

No. I did not test your script.
You said you wanted to know how to stop it from deleting the row.
So it's obvious you did not write the script.

Tell we what you are wanting to do?
Are you trying to copy any row with "Innlevert" in column "D"
To sheet named "I_produksjon"

Thank you for reply.
I tried to remove line, only gives me error.
Have you tested script without the line?

 

[My Aswer Is This]

Try this:

Sub Filter_Me()
Application.ScreenUpdating = False
'Modified 11-11-17 5:40 AM EST
Dim ans As String
ans = "Innlevert"
Sheets("Hertz").Activate
    With ActiveSheet.Range(Cells(1, 4), Cells(Cells(Rows.Count, 4).End(xlUp).Row, 4))
        .AutoFilter Field:=1, Criteria1:=ans
        .SpecialCells(xlCellTypeVisible).EntireRow.Copy Sheets("I_produksjon").Range("A1")
        .AutoFilter
    End With
    Application.ScreenUpdating = True
End Sub

 

[runeroan]

If I type text "Innlevert" in coloumn D in sheet "Hertz", the entire row has to be copied into next available row in sheet "I_oppdrag", but also stay in sheet "Hertz". Is that a good description of my need?

Excel file can be downloaded from
https://wetransfer.com/downloads/ec...load_button&utm_source=notify_recipient_email

Rune

No. I did not test your script.
You said you wanted to know how to stop it from deleting the row.
So it's obvious you did not write the script.

Tell we what you are wanting to do?
Are you trying to copy any row with "Innlevert" in column "D"
To sheet named "I_produksjon"

 

[My Aswer Is This]

I Never download files

In your original post you said:

Copy to:"I_produksjon"
Copy Destination:=Worksheets("I_produksjon
Now you say: I_oppdrag

So which is it?

And your original script performs the operation when you click a button.
Now you say:
If I type text "Innlevert" in coloumn D in sheet "Hertz", the entire row has to be copied into next available row in sheet "I_oppdrag

 

[runeroan]

Sorry, the correct is "I_produksjon"
If it could happen automatic it would be the best, a button to click can also work but prefer automatic copy entire row.

Thanks for help.

 

[My Aswer Is This]

Try this:
Script will run when you enter "Innlevert" into any cell in column "D"
The cell in column "D" will turn green letting you know this row has been copied over to make sure your not able to copy this row over twice by accident.
You must have a sheet named "I_produksjon"
This is an auto sheet event script
Your Workbook must be Macro enabled
To install this code:
Right-click on the sheet tab
Select View Code from the pop-up context menu
Paste the code in the VBA edit window

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Cells.Count > 1 Or IsEmpty(Target) Then Exit Sub
If Target.Column = 4 And Target.Value = "Innlevert" Then
If Target.Interior.ColorIndex = 4 Then MsgBox "That row has already been copied over": Exit Sub
Dim Lastrow As Long
Lastrow = Sheets("I_produksjon").Cells(Rows.Count, "D").End(xlUp).Row + 1
Rows(Target.Row).Copy Sheets("I_produksjon").Rows(Lastrow)
Target.Interior.ColorIndex = 4
End If
End Sub

 

[runeroan]

Worked fine, thank you for great knowledge and help!