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]

Put this script in sheet named "Hertz"

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
Application.EnableEvents = False
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)
Sheets("I_produksjon").Cells(Lastrow, 45).Value = Target.Row
Target.Interior.ColorIndex = 4
End If
Application.EnableEvents = True
End Sub

Put this script in sheet named "I_produksjon"

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 = "Levert" Then
Application.EnableEvents = False
Dim ans As Long
ans = Cells(Target.Row, 45).Value
Sheets("Hertz").Cells(ans, 4).Value = "Levert"
Sheets("Hertz").Cells(ans, 4).Interior.ColorIndex = xlNone
Rows(Target.Row).EntireRow.Delete
End If
Application.EnableEvents = True
End Sub

 

[runeroan]

Thank you so much, very kind of you to follow up and support me! I will give it a try today.

 

[My Aswer Is This]

OK. Let me know if it works.

Thank you so much, very kind of you to follow up and support me! I will give it a try today.

 

[runeroan]

Hi, could you make this happen?

In sheet "RES" I have a coloumn F named "Levert"
I would like to move entire row with existing fomulas to sheet "FAKT"
The moved row should be removed from sheet "RES" when moved to "sheet "FAKT"
The row needs to be placed on next availiable row in sheet "FAKT"

Can you make it happen?

 

[My Aswer Is This]

I do not understand what you want.

You said:
In sheet "RES" I have a coloumn F named "Levert"

Why do I care what the name is of column "F"

Do you mean if any row has the value "Levert" in column "F" then Copy this row to sheet named "FAKT" ?

 

[runeroan]

Thanks for feedback.

Yes, if any row has the value "Levert" in column "F" then Copy this row to sheet named "FAKT".

 

[My Aswer Is This]

Try this:

Sub Filter_Me()
'Modified 1-4-2018 7:05 AM EST
Dim Lastrow As Long
Lastrow = Sheets("FAKT").Cells(Rows.Count, "F").End(xlUp).Row + 1
Sheets("RES").Activate
    With ActiveSheet.Range("F1:F" & Cells(Rows.Count, "F").End(xlUp).Row)
        .AutoFilter 1, "Levert"
        .Offset(1).SpecialCells(12).EntireRow.Copy Sheets("FAKT").Range("A" & Lastrow)
        .Offset(1).SpecialCells(12).EntireRow.Delete
        .AutoFilter
    End With
Sheets("RES").Rows(1).Copy Sheets("FAKT").Rows(1)
End Sub

 

[runeroan]

Thanks.
Is it possible to copy row with all existing formulas into sheet "Fakt"?

 

[My Aswer Is This]

Try this:

Sub Filter_Me()
'Modified 1-4-2018 9:45 AM EST
Dim Lastrow As Long
Lastrow = Sheets("FAKT").Cells(Rows.Count, "F").End(xlUp).Row + 1
Sheets("RES").Activate
    With ActiveSheet.Range("F1:F" & Cells(Rows.Count, "F").End(xlUp).Row)
        .AutoFilter 1, "Levert"
        .Offset(1).SpecialCells(12).EntireRow.Copy
        Sheets("FAKT").Range("A" & Lastrow).PasteSpecial Paste:=xlPasteFormulas
        Sheets("FAKT").Range("A" & Lastrow).PasteSpecial Paste:=xlPasteFormats
        .Offset(1).SpecialCells(12).EntireRow.Delete
        .AutoFilter
    End With
Sheets("RES").Rows(1).Copy Sheets("FAKT").Rows(1)
End Sub

 

[runeroan]

Hi,

I cannot get any of them to work. In what sheet should I paste the script?