Copy Row to Seperate Sheet Based on Multiple Criteria

[ExcelEndeavor]

I have a report that I need to automaticallty filter out all of the rows that are not affected by the multiple criteria below. On the screenshot below, I paste the data from a report that I pull daily. To help visualize it, I manually went through and selected those items that need to be addressed (in red). I want to eliminate the rows that do not have issues, so we can focus only on the problem files. Not sure if I need a formula or VBA.

I want to only show the rows with the following criteria:

Column C (HCLTV)
>80.001 then Column D cannot be "AVM"
>90,001 (Anything over 90%)

Column B (Loan Amount)
>400,001 then Column D cannot be "AVM"
>500,001 then Column D cannot be "AVM", "Exterior", "Hybrid Exterior", or "Hybrid Interior"


As you can see on my attachment, some rows might be affected my more than one of the criteria, thus multiple red cells in a row.

Thank you in advance for your help.

 

[Trebor76]

Hi ExcelEndeavor,

Try this:

Option Explicit
Sub Macro1()

    Dim wsFrom As Worksheet, wsTo As Worksheet
    Dim lngRowTo As Long, lngRow As Long, lngPasteRow As Long
    Dim blnInvestigate As Boolean
    
    Application.ScreenUpdating = False
    
    Set wsFrom = ThisWorkbook.Sheets("Sheet1") '<-Sheet name containing raw data. Change to suit.
    Set wsTo = ThisWorkbook.Sheets("Sheet2") '<-Sheet name for items to be investigated. Change to suit.
    
    lngRowTo = wsFrom.Range("A:D").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    
    For lngRow = 2 To lngRowTo
        If Round(wsFrom.Range("C" & lngRow), 3) > 80.001 And wsFrom.Range("D" & lngRow) = "AVM" Then
            blnInvestigate = True
        ElseIf Round(wsFrom.Range("C" & lngRow), 3) > 90.001 Then
            blnInvestigate = True
        ElseIf Round(wsFrom.Range("B" & lngRow), 0) > 400001 And wsFrom.Range("D" & lngRow) = "AVM" Then
            blnInvestigate = True
        ElseIf Round(wsFrom.Range("B" & lngRow), 0) > 500001 Then
            If wsFrom.Range("D" & lngRow) = "AVM" Or wsFrom.Range("D" & lngRow) = "Exterior" Or wsFrom.Range("D" & lngRow) = "Hybrid Exterior" Or wsFrom.Range("D" & lngRow) = "Hybrid Interior" Then
                blnInvestigate = True
            End If
        End If
        If blnInvestigate = True Then
            If lngPasteRow = 0 Then
                lngPasteRow = 2
            Else
                lngPasteRow = wsTo.Range("A:D").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1
            End If
            wsFrom.Range("A" & lngRow & ":D" & lngRow).Copy Destination:=wsTo.Range("A" & lngPasteRow)
        End If
        blnInvestigate = False
    Next lngRow
    
    With Application
        .CutCopyMode = False
        .ScreenUpdating = True
    End With
    
End Sub

Note for Ahlers none of the exception criteria are met so it should not be considered.

Regards,

Robert