根据条件将单元格从特定列复制到另一个工作表
我有两个工作表，“签名”和“四月”。 我想根据特定的标准将“Y”从“Signed”复制到“April”的列“A”中，从下一个可用/空白行开始。 （就在现有数据的基础上）。 我列Y的标准是，如果列L =从“四月”的细胞“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 像这样的东西应该为你工作：
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
这是一个通用脚本，您可以根据需要轻松修改以处理几乎任何条件。
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