Multiple Criteria to Check Before Moving Data Between Sheets

[mharper90]

I copied the full macro at the bottom of this post, but here's the snippet of it that I'm struggling with.

    If Not IsError(Application.Match(x, ws1.Range("A:A"), 0)) Then             '//Copy and paste Name, TLD#, & Dates
                                                                               'from Main Data page to Figure 2—2
        ws1.Range("E:F").EntireColumn.Hidden = False                           'above for all members with
                                                                               ' "NO" ERC.
        ws1. Range("A3"). CurrentRegion. AutoFilter Field:=1, Criteria1:=x     '
        Intersect(ws1.AutoFilter.Range.Offset(1), multiAreaRange).Copy _
            Destination: =ws2.Range("A" & Rows.Count).End(xlUp).Offset(1)      '
        ws1.AutoFilterMode = False                                             '
                                                                               '
        ws1.Range("E:F").EntireColumn.Hidden = True                            '
                                                                               '
    End If                                                                     '//

I did not write this portion of the code, and don't really know exactly how it works. It currently does the function of searching ws1 for every row that has "NO" in Column A, and then copies and pastes portions of that row to ws2.

I want to add the ability for it to look for TWO criteria. "NO" in Column A, AND "TRUE" in Column S. Thus requiring both criteria to be met in order to copy and paste the associated row to ws2.

Thanks for the help! (I really need the code to work, but if anyone can help explain how this section of code works in the first place, I'd love to learn)

Sub cpypste5()


    Dim x    As String
    Dim ws1 As Worksheet: Set ws1 = ThisWorkbook.Sheets("Main Data")
    Dim ws2 As Worksheet
    Dim r1     As Range, r2 As Range, r3 As Range, r4 As Range, r5 As Range, multiAreaRange As Range
    Dim c     As Range
    Dim Lr     As Long


        Set r1 = ws1.Range("B B")
        Set r2 = ws1.Range("C:C")
        Set r3 = ws1.Range("E E")
        Set r4 = ws1.Range("F F")
        Set r5 = ws1.Range("H:H")


    If ws1.Range("$C$4") = "1" Then                 '//Uses Period # from Main Data sheet
        Set ws2 = ThisWorkbook.Sheets("P1 Figure 2—2")         'to direct data to the correct period's
        ElseIf ws1.Range("$C$4") = "2" Then             'Figure 2—2
        Set ws2 = ThisWorkbook.Sheets("P2 Figure 2—2")         '
        ElseIf ws1.Range("$C$4") = "3" Then             'Max of 8 Periods
        Set ws2 = ThisWorkbook.Sheets("P3 Figure 2—2")        '
        ElseIf ws1.Range("$C$4") = "4" Then            '
        Set ws2 = ThisWorkbook.Sheets("P4 Figure 2—2")        '
        Else: Exit Sub                        '
    End If                                //


    Set multiAreaRange = Union(r1, r2, r3, r4, r5)
    
Application.ScreenUpdating = False


    x = "NO"


    ws2.Rows("3:" & Rows.Count).Delete                     'Clears Figure 2-2 selected above


    If Not IsError(Application.Match(x, ws1.Range("A:A"), 0)) Then             '//Copy and paste Name, TLD#, & Dates
                                            'from Main Data page to Figure 2—2
        ws1.Range("E:F").EntireColumn.Hidden = False                'above for all members with
                                            ' "NO" ERC.
        ws1. Range("A3"). CurrentRegion. AutoFilter Field:=1, Criteria1:=x    '
        Intersect(ws1.AutoFilter.Range.Offset(1), multiAreaRange).Copy _
            Destination: =ws2.Range("A" & Rows.Count).End(xlUp).Offset(1)    '
        ws1.AutoFilterMode = False                        '
                                            '
        ws1.Range("E:F").EntireColumn.Hidden = True                '
                                            '
    End If                                        '//


SortGroup2Printout                                'Alphabetizes Figure 2-2


    ws2.Range("A:F").Interior.ColorIndex = xlNone                'Removes any background color copied over


    Lr = ws2.Range("A" & Rows.Count).End(xlUp).Row


    If Lr > 2 Then
        ws2.Range("F3:F" & Lr).Formula = "=VLOOKUP(A3,'Main Data'!B:N,8,FALSE)"
        ws2.Range("G3:G" & Lr).Formula = "=VLOOKUP(A3,'Main Data'!B:N,9,FALSE)"
        ws2.Range("H3:H" & Lr).Formula = "=VLOOKUP(A3,'Main Data'!B:N,10,FALSE)"
        ws2.Range("I3:I" & Lr).Formula = "=VLOOKUP(A3,'Main Data'!B:N,11,FALSE)"
        ws2.Range("J3:J" & Lr).Formula = "=VLOOKUP(A3,'Main Data'!B:N,12,FALSE)"
        ws2.Range("K3:K" & Lr).Formula = "=VLOOKUP(A3,'Main Data'!B:N,13,FALSE)"
        ws2.Range("L3:L" & Lr).Formula = "=VLOOKUP(A3,'Main Data'!B:N,14,FALSE)"
        ws2.Range("M3:M" & Lr).Formula = "=VLOOKUP(A3,'Main Data'!B:N,15,FALSE)"
        If ws1.Range("$C$4") = "1" Then
            ws2.Range("N3:N" & Lr).Formula = "=E3-F3"
            ws2.Range("O3:O" & Lr).Formula = "=VLOOKUP(A3,'Main Data'!B:N,8,FALSE)"
        ElseIf ws1.Range("$C$4") = "2" Then
            ws2.Range("N3:N" & Lr).Formula = "=E3-SUM(F3:G3)"
            ws2.Range("O3:O" & Lr).Formula = "=VLOOKUP(A3,'Main Data'!B:N,9,FALSE)"
        ElseIf ws1.Range("$C$4") = "3" Then
            ws2.Range("N3:N" & Lr).Formula = "=E3-SUM(F3:H3)"
            ws2.Range("O3:O" & Lr).Formula = "=VLOOKUP(A3,'Main Data'!B:N,10,FALSE)"    
        ElseIf ws1.Range("$C$4") = "4" Then
            ws2.Range("N3:N" & Lr).Formula = "=E3-SUM(F3:I3)"
            ws2.Range("O3:O" & Lr).Formula = "=VLOOKUP(A3,'Main Data'!B:N,11,FALSE)"
        ElseIf ws1.Range("$C$4") = "5" Then
            ws2.Range("N3:N" & Lr).Formula = "=E3-SUM(F3:J3)"
            ws2.Range("O3:O" & Lr).Formula = "=VLOOKUP(A3,'Main Data'!B:N,12,FALSE)"
        ElseIf ws1.Range("$C$4") = "6" Then
            ws2.Range("N3:N" & Lr).Formula = "=E3-SUM(F3:K3)"
            ws2.Range("O3:O" & Lr).Formula = "=VLOOKUP(A3,'Main Data'!B:N,13,FALSE)"
        ElseIf ws1.Range("$C$4") = "7" Then
            ws2.Range("N3:N" & Lr).Formula = "=E3-SUM(F3:L3)"
            ws2.Range("O3:O" & Lr).Formula = "=VLOOKUP(A3,'Main Data'!B:N,14,FALSE)"
        ElseIf ws1.Range("$C$4") = "8" Then
            ws2.Range("N3:N" & Lr).Formula = "=E3-SUM(F3:M3)"
            ws2.Range("O3:O" & Lr).Formula = "=VLOOKUP(A3,'Main Data'!B:N,15,FALSE)"
        End If
    Else
    End If


Run ("clearzeros")                            'Removes zeros from column O based on verification




    For Each c In ws2.Range("C3:D" & Lr)                    '//Removes issue/collection dates
        If c > Date Then                        'if they are in the future.
            c = ""                            '
        Else                                '
        End If                                '
    Next                                    '//




    With ws2
        With Application.ErrorCheckingOptions
            .BackgroundChecking = False
            .EvaluateToError = False
            .InconsistentFormula = False
        End With
    End With




    ws2.Range("A1:O" & Lr).Borders.LineStyle = xlContinuous            
    ws2.Range("A1:0" & Lr).BorderAround _
        ColorIndex:=1, Weight:=xlMedium


    With ws2.Range("A" & Rows.Count).End(xlUp).Offset(5, 1)            '//Places CRA Review Box 4 rows
        .Value = "Closeout Review: _______________ Date: _________"    'under last data row.
        With ws2.Range("A” & Rows.Count).End(xlUp).Offset(6, 1)        '
            .Value = "               CRA"                '
        End With                            '
        .Resize(3, 13).Offset(-1, 0).BorderAround _
            ColorIndex:=1, Weight:=xlMedium                '
    End With                                '//


Application.ScreenUpdating = True
End Sub

 

[ttray33y]

if the current code you are using is already good then it is better just to call this subs from a sub.
try:

Sub MeMeoftheDay()

Dim Alrow As Long
Dim i As Long

Alrow = ActiveWorkbook.ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row

Application.ScreenUpdating = False

    If Alrow = 1 Then
        Exit Sub
    End If

For i = 2 To Alrow [COLOR=#00ff00]'loop[/COLOR]
        If ActiveWorkbook.ActiveSheet.Cells(i, 1) = [B][COLOR=#0000ff]"A"[/COLOR][/B] And ActiveWorkbook.ActiveSheet.Cells(i, 19) = [B][COLOR=#0000ff]True[/COLOR][/B] Then
            [B][COLOR=#ff0000]cpypste5 [/COLOR][/B][COLOR=#00ff00]'your sub routine[/COLOR]
                Else
                    Exit Sub
        End If
Next i
Application.ScreenUpdating = True

End Sub

Just call me tray but everyone calls me Edd it's more fun in the Philippines.

 

[My Aswer Is This]

I believe your saying you do not know what any of this code is doing.

So it would be easier for me if you were to just say in words what your wanting to do.

I see your wanting this:

I want to add the ability for it to look for TWO criteria. "NO" in Column A, AND "TRUE" in Column S. Thus requiring both criteria to be met in order to copy and paste the associated row to ws2.

Is that all your wanting to do? Have the script look down column A for "NO" and "True" in column S

And your want to search Sheet named "Sheet1" and copy into sheet named "Sheet2"

Is this correct?

The script your showing here does all sorts of things.
​

 

[mharper90]

Thanks for the quick response. Maybe I'm not reading your code suggestion correctly, but "cpypste5" is a large macro that does several processes. I don't want to repeat unnecessary processes over and over again, which it looks like this loop will do. I only need the first snippet of code I posted in my original question to be "repeated" for each cell in ws1 to look for rows that meet both criteria, and then copy and paste those cells.

I'm not attached to the original code. If there's another way that you recommend to look through ws1 ("A7:A" & Lr) for rows that meet the criteria of "NO" in Column A and "TRUE" in Column S, and then transcribe rows that meet the criteria to ws2, then I'd be excited to see that method. Also, of rows that meet the criteria to be copied, only the cells in that row of columns B, C, E, F, and H need to be transcribed, and they should be transcribed to ws2 in that order (column B data from ws1 becomes column A in ws2, ws1 C to ws2 B, ws1 E to ws2 C, and so on).

 

[mharper90]

Looks like we were typing at the same time.

I understand this macro (I wrote most of it), with the exception of the first snippet I posted in the original question. Someone else wrote this, and I've used it because it's worked so far. Now that I want to modify this to add a second criteria, I don't understand this snippet enough to know how to modify it. I added my specific criteria to the 2nd paragraph of my last response. If that's a better way for me to ask for help, then please, use that. I was hoping that providing the current code would help someone on here assist with a simple modification that I am overlooking due to my lack of understanding for Autofilters and Intersections. Thanks

 

[My Aswer Is This]

I'm sorry. I'm not very good at reading other users code and then modifying it to meet there new needs.

This is beyond my knowledgebase.
I will continue to monitor this thread to see what I can learn.

 

[mharper90]

Still looking for help with the initial question. Thanks! *BUMP*

 

[Fluff]

How about

If Not IsError(Application.Match(x, Ws1.Range("A:A"), 0)) Then
                                                                           
    Ws1.Range("E:F").EntireColumn.Hidden = False
                                                                         
    Ws1.Range("A3").CurrentRegion.AutoFilter 1, x
    Ws1.Range("A3").CurrentRegion.AutoFilter 19, [COLOR=#ff0000]True[/COLOR]
    Intersect(Ws1.AutoFilter.Range.Offset(1), multiAreaRange).Copy _
        Destination:=Ws2.Range("A" & Rows.Count).End(xlUp).Offset(1)
    Ws1.AutoFilterMode = False
                                                                           
    Ws1.Range("E:F").EntireColumn.Hidden = True
                                                                           
End If

If your values in col S are text, rather than logical values wrap the word in red in quotes