Modify Cut Paste

[Emoncada]

I have the following code

Private Sub Worksheet_Change(ByVal Target As Range)

If Target.Count > 1 Then Exit Sub

'Change in Column H
If Target.Column <> 8 Then Exit Sub
If Target.Value > 0 Then
Application.ScreenUpdating = False
Application.EnableEvents = False
Dim myrow As Long
myrow = Target.Row
Target.EntireRow.Cut
Sheets("Completed").Range("A65536").End(xlUp).Offset(1, 0).Insert 'shift:=xlDown
Sheets("Tommy").Range("A" & myrow).EntireRow.Delete
Application.ScreenUpdating = True
Application.EnableEvents = True
End If
End Sub


Works great, but i need to modify it.
I want to add an update button to do this task, but for a range.
This code once it gets a value in Column "H" it cuts it and pastes it in the "Completed" sheet.
I want to be able to have several rows with Data in Column "H" then when someone clicks "Update" button it will cut those rows and paste in "Completed".

Any help would be great.

Thanks

[shrivallabha]

Test this code on a backup:
Public Sub CutAndPaste()
Application.ScreenUpdating = False
Application.EnableEvents = False
For i = 2 To Range("H" & Rows.Count).End(xlUp).Row
If Range("H" & i).Value > 0 Then
Range("A" & i).EntireRow.Cut
Sheets("Completed").Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Insert
End If
Next i
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub

[winon]

You say :


I want to add an update button to do this task, but for a range.


you also state:


I want to be able to have several rows with Data in Column "H" then when someone clicks "Update" button it will cut those rows and paste in "Completed".

Assuming you want to cut & insert the Entire Row/s, this is how I would do it. Add any Button of your choice to Sheet "Tommy", and insert the Code below in a standard module. (Remember to assign the Macro to the button.:) )

Sub UpDate()
Dim FirstCell As Range, LastCell As Range
Application.ScreenUpdating = False
Application.EnableEvents = False
Set LastCell = Cells(Cells.Find(What:="*", SearchOrder:=xlRows, _
SearchDirection:=xlPrevious, LookIn:=xlValues).Row, _
Cells.Find(What:="*", SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, LookIn:=xlValues).Column)
Set FirstCell = Cells(Cells.Find(What:="*", After:=LastCell, _
SearchOrder:=xlRows, SearchDirection:=xlNext, LookIn:=xlValues).Row, _
Cells.Find(What:="*", After:=LastCell, SearchOrder:=xlByColumns, _
SearchDirection:=xlNext, LookIn:=xlValues).Column)
Range(FirstCell, LastCell).EntireRow.Select
Selection.Cut
Sheets("Completed").Select
Cells(2, 8).Select
Selection.EntireRow.Insert Shift:=xlDown
Sheets("Tommy").Select
Range("A2").Select
Sheets("Completed").Select
Range("H14").Select

Application.ScreenUpdating = True
Application.EnableEvents = True
Application.CutCopyMode = False
End Sub

Hope that helps!:hi:

[winon]

Sorry! The code as posted above is incomplete.:(

Please replace with Code below.:)

Sub UpDate()
Dim FirstCell As Range, LastCell As Range
Application.ScreenUpdating = False
Application.EnableEvents = False
If Application.WorksheetFunction.CountA(Columns("H")) = 0 Then
MsgBox ("No data Exist to Copy"), vbOKOnly, ("System Check")
Exit Sub
Else:
Set LastCell = Cells(Cells.Find(What:="*", SearchOrder:=xlRows, _
SearchDirection:=xlPrevious, LookIn:=xlValues).Row, _
Cells.Find(What:="*", SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, LookIn:=xlValues).Column)
Set FirstCell = Cells(Cells.Find(What:="*", After:=LastCell, _
SearchOrder:=xlRows, SearchDirection:=xlNext, LookIn:=xlValues).Row, _
Cells.Find(What:="*", After:=LastCell, SearchOrder:=xlByColumns, _
SearchDirection:=xlNext, LookIn:=xlValues).Column)
Range(FirstCell, LastCell).EntireRow.Select
Selection.Cut
Sheets("Completed").Select
Cells(2, 8).Select
Selection.EntireRow.Insert Shift:=xlDown
Sheets("Tommy").Select
Range("A2").Select
Sheets("Completed").Select
Range("H14").Select
End If
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.CutCopyMode = False
End Sub

[Emoncada]

I have the following Code

Public Sub CutAndPaste()
Application.ScreenUpdating = False
Application.EnableEvents = False
For i = 5 To Range("H" & Rows.Count).End(xlUp).Row

If Range("H" & i).Value > 0 Then
Range("A" & i).EntireRow.Cut
Sheets("Completed").Range("A65536").End(xlUp).Offset(1, 0).Insert 'shift:=xlDown
End If
Next i
Call DeleteBlankARows

ActiveWorkbook.Save

Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
Sub DeleteBlankARows()
Dim r As Long
For r = Cells(Rows.Count, 1).End(xlUp).Row To 5 Step -1
If Cells(r, 1) = "" Then Rows(r).Delete
Next r
End Sub

Which works, but it takes too long.
Can anyone see how this code can be modified and possibly make it work faster?

What it does is it grabs all rows with data in Column H and cut's it and pastes it in the next available row in Sheet ("Completed").

Then I have the "DeleteBlankARows" which then deletes all blank rows in original sheet to move everything else up.

Any help would be great, its currently taking about 2 minutes for it to do it's job.

Thanks,

[Teeroy]

@Shrivallabha's approach is simple and effective. It does need a small tweak though. When a row is deleted the next row moves up but since that row number has been checked it would be passed over. Reducing the value of i by 1 ensures that this row is checked.

Public Sub CutAndPaste()
Application.ScreenUpdating = False
Application.EnableEvents = False
For i = 2 To Range("H" & Rows.Count).End(xlUp).Row
If Range("H" & i).Value > 0 Then
Range("A" & i).EntireRow.Cut
Sheets("Completed").Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Insert
i = i-1 'added
End If
Next i
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub

[Emoncada]

BUMP!

Any other code I can use to accomplish this task?
This code works, but takes sometime for it to run.