根据条件将单元格从特定列复制到另一个工作表

Question

I have two worksheets, "Signed" and "April". I want to copy Column "Y" from "Signed" based on certain criteria into column "A" of "April" starting from the next available/blank row. ( so right under the existing data). My criteria for column Y is that if column L = month of cell "D2" from "April" AND the year of cell "D2" from "ApriL"...( so right now D2 is 4/30/2017).. then copy that cell in the next available row of Col A of "April" and keep adding on.

I've been trying several different things but just am not able to get it..any idea on how I can achieve this?

My code is below:

Set sourceSht = ThisWorkbook.Worksheets("Signed")
Set myRange = sourceSht.Range("Y1", Range("Y" & Rows.Count).End(xlUp))
Set ws2 = Sheets(NewSheet)
DestRow = ws2.Cells(Rows.Count, "A").End(xlUp).Row + 1



For Each rw In myRange.Rows
If rw.Cells(12).Value = "Month(Sheets(ws2).Range("D2"))" Then
myRange.Value.Copy Destinations:=Sheets(ws2).Range("A" & DestRow)

End If

Answer 1

Something like this should work for you:

Sub tgr()

    Dim wb As Workbook
    Dim wsData As Worksheet
    Dim wsDest As Worksheet
    Dim aData As Variant
    Dim aResults() As Variant
    Dim dtCheck As Date
    Dim lCount As Long
    Dim lResultIndex As Long
    Dim i As Long

    Set wb = ActiveWorkbook
    Set wsData = wb.Sheets("Signed")        'This is your source sheet
    Set wsDest = wb.Sheets("April")         'This is your destination sheet
    dtCheck = wsDest.Range("D2").Value2     'This is the date you want to compare against

    With wsData.Range("L1:Y" & wsData.Cells(wsData.Rows.Count, "L").End(xlUp).Row)
        lCount = WorksheetFunction.CountIfs(.Resize(, 1), ">=" & DateSerial(Year(dtCheck), Month(dtCheck), 1), .Resize(, 1), "<" & DateSerial(Year(dtCheck), Month(dtCheck) + 1, 1))
        If lCount = 0 Then
            MsgBox "No matches found for [" & Format(dtCheck, "mmmm yyyy") & "] in column L of " & wsData.Name & Chr(10) & "Exiting Macro"
            Exit Sub
        Else
            ReDim aResults(1 To lCount, 1 To 1)
            aData = .Value
        End If
    End With

    For i = 1 To UBound(aData, 1)
        If IsDate(aData(i, 1)) Then
            If Year(aData(i, 1)) = Year(dtCheck) And Month(aData(i, 1)) = Month(dtCheck) Then
                lResultIndex = lResultIndex + 1
                aResults(lResultIndex, 1) = aData(i, UBound(aData, 2))
            End If
        End If
    Next i

    wsDest.Cells(wsDest.Rows.Count, "A").End(xlUp).Offset(1).Resize(lCount).Value = aResults

End Sub

Alternate method using AutoFilter instead of iterating over an array:

Sub tgrFilter()

    Dim wb As Workbook
    Dim wsData As Worksheet
    Dim wsDest As Worksheet
    Dim dtCheck As Date

    Set wb = ActiveWorkbook
    Set wsData = wb.Sheets("Signed")        'This is your source sheet
    Set wsDest = wb.Sheets("April")         'This is your destination sheet
    dtCheck = wsDest.Range("D2").Value2     'This is the date you want to compare against

    With wsData.Range("L1:Y" & wsData.Cells(wsData.Rows.Count, "L").End(xlUp).Row)
        .AutoFilter 1, , xlFilterValues, Array(1, Format(WorksheetFunction.EoMonth(dtCheck, 0), "m/d/yyyy"))
        Intersect(.Cells, .Parent.Columns("Y")).Offset(1).Copy wsDest.Cells(wsDest.Rows.Count, "A").End(xlUp).Offset(1)
        .AutoFilter
    End With

End Sub

Answer 2

Here's a generic script which you can easily modify to handle almost ANY criteria, as needed.

Sub Copy_If_Criteria_Met()
    Dim xRg As Range
    Dim xCell As Range
    Dim I As Long
    Dim J As Long
    I = Worksheets("Sheet1").UsedRange.Rows.Count
    J = Worksheets("Sheet2").UsedRange.Rows.Count
    If J = 1 Then
       If Application.WorksheetFunction.CountA(Worksheets("Sheet2").UsedRange) = 0 Then J = 0
    End If
    Set xRg = Worksheets("Sheet1").Range("A1:A" & I)
    On Error Resume Next
    Application.ScreenUpdating = False
    For Each xCell In xRg
        If CStr(xCell.Value) = "X" Then
            xCell.EntireRow.Copy Destination:=Worksheets("Sheet2").Range("A" & J + 1)
            xCell.EntireRow.Delete
            J = J + 1
        End If
    Next
    Application.ScreenUpdating = True
End Sub