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]

no

 

[Fluff]

Any error messages?

 

[rubinda]

I started a brand new workbook from scratch and now it works. Thanks for the help. Now I need to insert the following pop-up message for the following: If the cell in column E is "Complete" but the cell to the right does not have a date, I'd like to message to read, "You have a completed item with no completion date". Also, is it possible to not let the macro complete if there is an error?

 

[mumps]

Try:

Sub CopyRows()
    Application.ScreenUpdating = False
    Dim LastRow As Long, rng As Range
    LastRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    Sheets("Edgewood-Open").Range("E1:E" & LastRow).AutoFilter Field:=1, Criteria1:="Complete"
    For Each rng In Sheets("Edgewood-Open").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-Open").AutoFilterMode = True Then Sheets("Edgewood-Open").AutoFilterMode = False
            Application.ScreenUpdating = True
            Exit Sub
        End If
    Next rng
    Sheets("Edgewood-Open").Range("E2:E" & LastRow).SpecialCells(xlCellTypeVisible).EntireRow.Copy Sheets("Edgewood-Closed").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
    Sheets("Edgewood-Open").Range("E2:E" & LastRow).SpecialCells(xlCellTypeVisible).EntireRow.Delete
    If Sheets("Edgewood-Open").AutoFilterMode = True Then Sheets("Edgewood-Open").AutoFilterMode = False
    Application.ScreenUpdating = True
End Sub

 

[rubinda]

No message appears and it copies to the other sheet

 

[rubinda]

Here is my full code now, I think I am doing something wrong...

Sub Edgewood()
    Dim xRg As Range
    Dim xCell As Range
    Dim I As Long
    Dim J As Long
    Dim K As Long
    I = Worksheets("Edgewood").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").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
    
    ActiveWorkbook.Save
    
    '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("E1:E" & LastRow).SpecialCells(xlCellTypeVisible).EntireRow.Copy Sheets("Edgewood-Closed").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
    'Sheets("Edgewood").Range("E1:E" & LastRow).SpecialCells(xlCellTypeVisible).EntireRow.Delete
    'If Sheets("Edgewood").AutoFilterMode = True Then Sheets("Edgewood").AutoFilterMode = False
    'Application.ScreenUpdating = True
    
    'ActiveWorkbook.Save
End Sub

 

[mumps]

Is the macro I suggested not working for you? If not, please describe in detail how it's not working.

 

[rubinda]

Its not doing anything. I am not seeing a message pop up.

 

[mumps]

It is always easier to help and test possible solutions if we could work with your actual file. Perhaps you could upload a copy of your file to a free site such as www.box.com or www.dropbox.com. Once you do that, mark it for 'Sharing' and you will be given a link to the file that you can post here. If the workbook contains confidential information, you could replace it with generic data.

 

[mumps]

Sorry, mis-posted. Still waiting for your file.