copy, paste selection based on multiple criteria to another worksheet in VBA

Question

I'm very new to VBA and have been using the Macro recorder to create Macros. The Macro recorder can only take me so far, I'm able to accomplish 2/3 of what I need done.

I'm trying to create a Macro where I need criteria met in three Columns, copy the row that meets the criteria, and paste it onto a workbook. The criteria are "Open" "Critical" and "Date." Here's the tricky part, the date either needs to be greater than a specific date, either through user input or referencing a cell in a third worksheet. There are a few thousand rows, and about 19 columns, and all the codes I've attempted lead to crashing excel.

Sample of the code to getting the first two criteria:

Sheets("Sheet1").Select
    ActiveSheet.ListObjects("Table_owssvr").Range.AutoFilter Field:=12, _
    Criteria1:="Open"
ActiveSheet.ListObjects("Table_owssvr").Range.AutoFilter Field:=16, _
    Criteria1:="Critical"
Range("Table_owssvr").Select
Range("Q83").Activate
Selection.Copy
Sheets("Sheet2").Select Worksheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Select
ActiveSheet.Paste

A-----------------------------------------------------------------B-----------------------------------------------------------C Open -------------------------------------------------------Critical--------------------------------------------------1/25---Open-------------------------------------------------------High------------------------------------------------------3/25 Closed----------------------------------------------------Critical----------------------------------------------------3/24 Open------------------------------------------------------Critical-----------------------------------------------------1/25

Any help would be great!

score 0 · Accepted Answer · answered Dec 06 '17 at 00:19

If you are going to be writing VBA you will have to eventually stop relying on .Select. Recorded code is fine short term but it is typically verbose and inefficient.

Option Explicit

Sub wqewqwew()
    Dim col1 As Long, col2 As Long, col3 As Long, dt As Date
    Dim ws2 As Worksheet

    Set ws2 = Worksheets("sheet2")

    With Worksheets("sheet1").ListObjects("Table_owssvr")
        With .HeaderRowRange
            col1 = Application.Match("open", .Cells, 0)
            col2 = Application.Match("critical", .Cells, 0)
            col3 = Application.Match("date", .Cells, 0)
            dt = CDate(Application.InputBox(prompt:="greater then when?", Title:="pick date", Default:=Date))
        End With
        With .Range
            .AutoFilter
            .AutoFilter field:=col1, Criteria1:="open"
            .AutoFilter field:=col2, Criteria1:="critical"
            .AutoFilter field:=col3, Criteria1:=">" & dt
        End With
        With .DataBodyRange
            If CBool(Application.Subtotal(103, .Cells)) Then
                .Copy Destination:=ws2.Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
            End If
        End With
        With .Range
            'turn off filters
            .AutoFilter
        End With
    End With
End Sub

You will likely want to research error control and add some to the above.

Recommended reading: How to avoid using Select in Excel VBA.

WOW this worked FLAWLESSLY! Just had to change the col1,col2,col3 names to their appropriate column name! And yes definitely, I notice a huge performance issue when I use the .select, iterating over thousands of rows of data, I can definitely integrate my code with your answer. Thanks! — MSauce, Dec 06 '17 at 15:04

score 0 · Answer 2 · answered Dec 06 '17 at 00:45

I designed it this way. Try it.

The complete file is below the link

Download File

Sheet1 : It's your row data and click function button

Sheet2 : It's mapping data according to "Open" & "Critical" & "Date" (The "Date" entered according to Sheet3)

Sheet3 : Enter the date you want

The complete code is as follows

Option Explicit

Private Sub Click_Click()

    Dim i As Integer

    For i = 2 To Worksheets("Sheet1").Range("A65536").End(xlUp).Row

        If Worksheets("Sheet1").Range("A" & i) = "Open" And _
            Worksheets("Sheet1").Range("B" & i) = "Critical" And _
            Worksheets("Sheet1").Range("C" & i) > Worksheets("Sheet3").Range("A2") Then

            Worksheets("Sheet1").Rows(i).Copy Worksheets("Sheet2").Range("A" & Worksheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Row + 1)

        End If
    Next

End Sub

copy, paste selection based on multiple criteria to another worksheet in VBA

2 Answers2