根據條件將單元格從特定列復制到另一個工作表

Question

我有兩個工作表，“簽名”和“ 4月”。 我想從下一個可用/空白行開始，基於某些條件將“已簽名”列中的“ Y”列復制到“四月”列“ A”中。 （在現有數據下也是如此）。 我對Y列的標准是，如果L列=來自“ April”的單元格“ D2”的月份和來自“ ApriL”的單元格“ D2”的年份...（所以D2現在是4/30/2017）。然后將該單元格復制到“ 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

使用自動篩選而不是遍歷數組的替代方法：

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