Macro to delete and replace cell contents required

[DancingElvisLives]

All,

Please open attachment when trying to assist in my problem.

Basically, I'm looking for a macro that will help me complete the following.

Insert a filter on Row 21, from Column B to I.

Filter for 'No' values in Column I.

Copy the cell contents of the filtered rows from Column B,C,D & E and paste in Sheet 2, Row A1

Delete cell contents of filtered 'No' value rows, but only the contents in Columns, B,C,D & E. Then insert in the rows that have just been deleted in Column C only the following text 'Wash Up Required'.

Loop until it comes to the bottom row.

Is this possible? Your the guys and girls to tell me.....

Thanks in advance for your help.

If you do not understand the content then please send an e-mail to <email address removed by moderator>

[tigeravatar]

DancingElvisLives,

I came up with a macro that does what you need it to do, but your workbook has links in it that were interrupting the macro. I think that's just because I don't have the workbook it was trying to access (was looking in a network drive, the K: drive, for: K:\Energy Department Folder\IServe 3\IServe 4.xls)

If you have access to that workbook, maybe the macro will work for you. I copied your data without links into a separate test workbook, and in there the macro ran with no problems. Here's the code:

Sub FindWashUps()
    
    Application.ScreenUpdating = False
    
    Dim LastItem As Long:       LastItem = ActiveSheet.Range("I" & Rows.Count).End(xlUp).Row
    Dim CurrentItem As Long:    CurrentItem = 22
    While CurrentItem <= LastItem
        If ActiveSheet.Range("I" & CurrentItem).Value = "No" Then
            Application.CutCopyMode = False
            ActiveSheet.Range("B" & CurrentItem & ":E" & CurrentItem).Copy
            If IsEmpty(Sheets("Sheet2").Range("A1")) Then
                Sheets("Sheet2").Range("A1").PasteSpecial
            Else
                Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial
            End If
            ActiveSheet.Range("B" & CurrentItem & ":E" & CurrentItem).ClearContents
            ActiveSheet.Range("C" & CurrentItem).Value = "Wash Up Required"
        End If
        CurrentItem = CurrentItem + 1
    Wend
    
    CutCopyMode = False
    Application.ScreenUpdating = True
    
End Sub

Hope that helps,
~tigeravatar

[teylyn]

DancingElvisLives, please keep the discussion of your question in this forum. Publishing your email address in a forum is also only a good idea if you want lots of spam in your inbox. I've removed the email address.

It might be a good idea for you to read and understand the forum rules before you post again.

Then change the thread title.

[watersev]

hi, DancingElvisLives, please check attachment, run code "test"