VBA Code - IF AND statements to identify rows, move to another tab and then hide

[amyloustafford]

Hi all

I'm hoping you can offer some advice please!! I have googled as much as I can to get to this point. I have a workbook, and I would like some coding that identifies if a contract is a "Contract - Framework" AND has a status of "Contract Awarded" on the "Procurement Tracker" tab. I would then like the relevant rows that meet this criteria to be copied over to another tab called "Live Contracts" and hidden on the original Procurement Tracker tab.

This is the formula I have so far that will move the rows that meet the "Contract - Framework" criteria, I would just like to know how to amend it so that the row meets both conditions;

Sub ReqToLive()
Dim xRg As Range
Dim xCell As Range
Dim I As Long
Dim J As Long
I = Worksheets("Procurement Tracker").UsedRange.Rows.Count
J = Worksheets("Live Contracts").UsedRange.Rows.Count
If J = 1 Then
If Application.WorksheetFunction.CountA(Worksheets("Live Contracts").UsedRange) = 0 Then J = 0
End If
Set xRg = Worksheets("Procurement Tracker").Range("F1:F" & I)
On Error Resume Next
Application.ScreenUpdating = False
For Each xCell In xRg
If CStr(xCell.Value) = "Contract - Framework" Then
xCell.EntireRow.Copy Destination:=Worksheets("Live Contracts").Range("A" & J + 1)
xCell.EntireRow.Hidden = True
J = J + 1
End If
Next
Application.ScreenUpdating = True
End Sub

Hope that makes sense! Thanks in advance
Amy

 

[Fluff]

Hello Amy & welcome to the board
Give this a go

Sub ReqToLive()
    Dim xRg As Range
    Dim xCell As Range
    Dim I As Long
    Dim J As Long
    I = Worksheets("Procurement Tracker").UsedRange.Rows.Count
    J = Worksheets("Live Contracts").UsedRange.Rows.Count
    If J = 1 Then
       If Application.WorksheetFunction.CountA(Worksheets("Live Contracts").UsedRange) = 0 Then J = 0
    End If
    Set xRg = Worksheets("Procurement Tracker").Range("F1:F" & I)
    [COLOR=#ff0000]On Error Resume Next[/COLOR]
    Application.ScreenUpdating = False
    For Each xCell In xRg
         If CStr(xCell.Value) = "Contract - Framework" And CStr(xCell.Offset(0, [COLOR=#0000ff]1[/COLOR]).Value) = "Contract Awarded" Then
            xCell.EntireRow.Copy Destination:=Worksheets("Live Contracts").Range("A" & J + 1)
            xCell.EntireRow.Hidden = True
            J = J + 1
        End If
    Next
    Application.ScreenUpdating = True
End Sub

You'll need to change the offset value to match your data (at the moment this works on column G)
I'd also strongly recommend that you remove the line in red, as this will simply mask any errors without telling you that there is a problem.

ps this is untested