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

Question

我有两个工作表，“签名”和“四月”。我想根据一定的标准将“Y”从“Signed”复制到“April”的列“A”中，从下一个可用/空白行开始。 （就在现有数据的基础上）。 对于Y列的我的标准是，如果列L =“4月”的单元格“D2”的月份和“ApriL”的单元格的年份...（因此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 

使用自动筛选，而不是迭代数组

替代方法：

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