Moving row based on value

[rubinda]

I am using the code below. When I activate the macro, the appropriate row disappears, but it is not pasted anywhere.

Sub EdgewoodOpen()
    Dim xRg As Range
    Dim xCell As Range
    Dim I As Long
    Dim J As Long
    Dim K As Long
    I = Worksheets("Edgewood-Open").UsedRange.Rows.Count
    J = Worksheets("Edgewood-Closed").UsedRange.Rows.Count
    If J = 1 Then
       If Application.WorksheetFunction.CountA(Worksheets("Edgewood-Closed").UsedRange) = 0 Then J = 0
    End If
    Set xRg = Worksheets("Edgewood-Open").Range("E1:E" & I)
    On Error Resume Next
    Application.ScreenUpdating = False
    For K = 1 To xRg.Count
        If CStr(xRg(K).Value) = "Complete" Then
            xRg(K).EntireRow.Copy Destination:=Worksheets("Edgewood-Closed").Range("A" & J + 1)
            xRg(K).EntireRow.Delete
            If CStr(xRg(K).Value) = "Complete" Then
                K = K - 1
            End If
            J = J + 1
        End If
    Next
    Application.ScreenUpdating = True
End Sub

 

[rubinda]

The code below allows the pop up message to appear, but it pops up even if column E states "Open".

I would like the message to pop up only if column E states “Complete” and the next cell to the right in column F is blank.

If column E states “Complete” and there is a date in the next cell to the right in column F, I’d like the copy/paste/delete piece to happen.

THANK YOU for your help.

Sub Edgewood()
Application.ScreenUpdating = False
Dim LastRow As Long, rng As Range
LastRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
Sheets("Edgewood").Range("E1:E" & LastRow).AutoFilter Field:=1, Criteria1:="Complete"
For Each rng In Sheets("Edgewood").Range("E2:E" & LastRow).SpecialCells(xlCellTypeVisible)
If rng.Offset(0, 1) = "" Then
MsgBox ("You have a completed an item with no completion date.") & Chr(10) & "Please enter a date in cell " & rng.Offset(1, 0).Address(0, 0)
rng.Offset(1, 0).Select
If Sheets("Edgewood").AutoFilterMode = True Then Sheets("Edgewood").AutoFilterMode = False
Application.ScreenUpdating = True
Exit Sub
End If
Next rng
Sheets("Edgewood").Range("E2:E" & LastRow).SpecialCells(xlCellTypeVisible).EntireRow.Copy Sheets("Edgewood-Closed").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
Sheets("Edgewood").Range("E2:E" & LastRow).SpecialCells(xlCellTypeVisible).EntireRow.Delete
If Sheets("Edgewood").AutoFilterMode = True Then Sheets("Edgewood").AutoFilterMode = False
Application.ScreenUpdating = True
End Sub

 

[mumps]

Try this version:

Sub Edgewood()
    Application.ScreenUpdating = False
    Dim LastRow As Long, rng As Range
    LastRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    Sheets("Edgewood").Range("E1:E" & LastRow).AutoFilter Field:=1, Criteria1:="Complete"
    For Each rng In Sheets("Edgewood").Range("E2:E" & LastRow).SpecialCells(xlCellTypeVisible)
        If rng.Offset(0, 1) = "" Then
            MsgBox ("You have a completed an item with no completion date.") & Chr(10) & "Please enter a date in cell " & rng.Offset(0, 1).Address(0, 0)
            rng.Offset(0, 1).Select
            If Sheets("Edgewood").AutoFilterMode = True Then Sheets("Edgewood").AutoFilterMode = False
            Application.ScreenUpdating = True
            Exit Sub
        End If
    Next rng
    Sheets("Edgewood").Range("E2:E" & LastRow).SpecialCells(xlCellTypeVisible).EntireRow.Copy Sheets("Edgewood-Closed").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
    Sheets("Edgewood").Range("E2:E" & LastRow).SpecialCells(xlCellTypeVisible).EntireRow.Delete
    If Sheets("Edgewood").AutoFilterMode = True Then Sheets("Edgewood").AutoFilterMode = False
    Application.ScreenUpdating = True
End Sub

Please use code tags when posting code.