Im trying to move entire rows automatically based on criteria from one sheet to another and then back if needed. I found code that lets me move an entire row from one sheet to another sheet, and it works perfectly. However I would like to be able to move it back automatically based on criteria if needed. The sheet is for tool inventory. When a tool comes back from a job I type "yes" in the returned column and that row gets moved to the returned sheet and deleted from the out sheet, but I want to be able to move it back to the out sheet automatically when I send it back out. Below is the code I'm using now .
Module Code is
Sub MoveBasedOnValue()
'Created by Excel 10 Tutorial
Dim xRg As Range
Dim xCell As Range
Dim A As Long
Dim B As Long
Dim C As Long
A = Worksheets("Out").UsedRange.Rows.Count
B = Worksheets("Returned").UsedRange.Rows.Count
If B = 1 Then
If Application.WorksheetFunction.CountA(Worksheets("Returned").UsedRange) = 0 Then B = 0
End If
Set xRg = Worksheets("Out").Range("H1:H" & A)
On Error Resume Next
Application.ScreenUpdating = False
For C = 1 To xRg.Count
If CStr(xRg(C).Value) = "yes" Then
xRg(C).EntireRow.Copy Destination:=Worksheets("Returned").Range("A" & B + 1)
xRg(C).EntireRow.Delete
If CStr(xRg(C).Value) = "yes" Then
C = C - 1
End If
B = B + 1
End If
Next
Application.ScreenUpdating = True
End Sub
Sheet Code is
Private Sub Worksheet_Change(ByVal Target As Range)
'Subscribe to youtube.com/excel10tutorial
Dim Z As Long
Dim xVal As String
On Error Resume Next
If Intersect(Target, Range("H:H")) Is Nothing Then Exit Sub
Application.EnableEvents = False
For Z = 1 To Target.Count
If Target(Z).Value > 0 Then
Call MoveBasedOnValue
End If
Next
Application.EnableEvents = True
End Sub
Module Code is
Sub MoveBasedOnValue()
'Created by Excel 10 Tutorial
Dim xRg As Range
Dim xCell As Range
Dim A As Long
Dim B As Long
Dim C As Long
A = Worksheets("Out").UsedRange.Rows.Count
B = Worksheets("Returned").UsedRange.Rows.Count
If B = 1 Then
If Application.WorksheetFunction.CountA(Worksheets("Returned").UsedRange) = 0 Then B = 0
End If
Set xRg = Worksheets("Out").Range("H1:H" & A)
On Error Resume Next
Application.ScreenUpdating = False
For C = 1 To xRg.Count
If CStr(xRg(C).Value) = "yes" Then
xRg(C).EntireRow.Copy Destination:=Worksheets("Returned").Range("A" & B + 1)
xRg(C).EntireRow.Delete
If CStr(xRg(C).Value) = "yes" Then
C = C - 1
End If
B = B + 1
End If
Next
Application.ScreenUpdating = True
End Sub
Sheet Code is
Private Sub Worksheet_Change(ByVal Target As Range)
'Subscribe to youtube.com/excel10tutorial
Dim Z As Long
Dim xVal As String
On Error Resume Next
If Intersect(Target, Range("H:H")) Is Nothing Then Exit Sub
Application.EnableEvents = False
For Z = 1 To Target.Count
If Target(Z).Value > 0 Then
Call MoveBasedOnValue
End If
Next
Application.EnableEvents = True
End Sub