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

Question

我有两个工作表，“签名”和“四月”。我想从下一个可用/空白行开始，根据某些条件将“已签名”中的“Y”列复制到“4 月”的“A”列中。 （所以就在现有数据之下）。 我对 Y 列的标准是，如果列 L =“April”中的单元格“D2”的月份和“ApriL”中的单元格“D2”的年份......（所以现在 D2 是 2017 年 4 月 30 日）..然后将该单元格复制到“April”的 Col A 的下一个可用行中并继续添加。

我一直在尝试几种不同的东西，但就是无法做到。我知道如何实现这一点吗？

我的代码如下：

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

这样的东西应该适合你：

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

使用 AutoFilter 代替遍历数组的替代方法：

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

这是一个通用脚本，您可以根据需要轻松修改它以处理几乎任何标准。

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