将满足特定条件的行复制到我的数据的底部

我有以下问题，例如，如果我有以下数据：

Alex 12/9/2013 John 11/30/2013 Irene 10/1/2013 Eve 9/9/2013 Max 1//30/2014 Stanley 1/1/2013 

如果我希望对于每天超过45天（> 45天）的行，整行将被复制到下一个新行。 因此，结果将是原始数据加上另外3行的date已经超过45天从今天。 （我需要它更有活力）。 我可以find一些类似的样本，但无法修改它以适应我的需要。

 Alex 12/9/2013 John 11/30/2013 Irene 10/1/2013 Eve 9/9/2013 Max 1//30/2014 Stanley 1/1/2013 Irene 10/1/2013 Expired Eve 9/9/2013 Expired Stanley 1/1/2013 Expired 

码

 Sub Macro7() Range("A1:C1").Select Selection.AutoFilter ActiveSheet.Range("$A$1:$C$7").AutoFilter Field:=3, Criteria1:="yes" Range("A4:B7").Select Selection.Copy Range("A8").Select ActiveSheet.Paste ActiveSheet.Range("$A$1:$C$10").AutoFilter Field:=3 Application.CutCopyMode = False Selection.AutoFilter Range("C1").Select Selection.End(xlDown).Select Range("C8").Select ActiveCell.FormulaR1C1 = "Expired" Range("C8").Select Selection.Copy Range("B8").Select Selection.End(xlDown).Select Range("C10").Select ActiveSheet.Paste Range(Selection, Selection.End(xlUp)).Select ActiveSheet.Paste Range("C11").Select End Sub 

Answer 1

避免使用。selectINTERESTING READ

现在你可以使用Autofilter这个，或者你可以使用下面我正在使用的方法。

假设你的工作表看起来像这样

逻辑：

循环遍历A列中的单元格，并使用DateDiff检查date是否大于45。

一旦find范围，我们不会将其复制到循环的最后，而是将其存储在温度范围内。 我们在代码的末尾复制范围。 这样，你的代码将运行得更快。

码：

 Option Explicit Sub Sample() Dim ws As Worksheet Dim lRow As Long, i As Long, OutputRow As Long Dim copyRng As Range '~~> Change this to the relevant worksheet Set ws = ThisWorkbook.Sheets("Sheet1") With ws '~~> Get LatRow in Col A lRow = .Range("A" & .Rows.Count).End(xlUp).Row OutputRow = lRow + 1 '~~> Loop through the cells For i = 1 To lRow If DateDiff("d", .Range("B" & i).Value, Date) > 45 Then If copyRng Is Nothing Then Set copyRng = .Range("A" & i & ":B" & i) Else Set copyRng = Union(copyRng, .Range("A" & i & ":B" & i)) End If End If Next i '~~> Copy the expired records in one go If Not copyRng Is Nothing Then copyRng.Copy .Range("A" & OutputRow) End With End Sub 

输出：

如果您想在Col C显示Expired ，请使用此选项

 Option Explicit Sub Sample() Dim ws As Worksheet Dim lRow As Long, i As Long, OutputRow As Long Dim copyRng As Range '~~> Change this to the relevant worksheet Set ws = ThisWorkbook.Sheets("Sheet1") With ws '~~> Get LatRow in Col A lRow = .Range("A" & .Rows.Count).End(xlUp).Row OutputRow = lRow + 1 '~~> Loop through the cells For i = 1 To lRow If DateDiff("d", .Range("B" & i).Value, Date) > 45 Then If copyRng Is Nothing Then Set copyRng = .Range("A" & i & ":B" & i) Else Set copyRng = Union(copyRng, .Range("A" & i & ":B" & i)) End If End If Next i '~~> Copy the expired records in one go If Not copyRng Is Nothing Then copyRng.Copy .Range("A" & OutputRow) lRow = .Range("A" & .Rows.Count).End(xlUp).Row .Range("C" & OutputRow & ":C" & lRow).Value = "Expired" End If End With End Sub 

输出：

编辑（从评论跟进）

这是你正在尝试？

 Option Explicit Sub Sample() Dim ws As Worksheet Dim lRow As Long, i As Long, OutputRow As Long Dim copyRng As Range '~~> Change this to the relevant worksheet Set ws = ThisWorkbook.Sheets("Sheet1") With ws '~~> Get LatRow in Col B lRow = .Range("B" & .Rows.Count).End(xlUp).Row OutputRow = lRow + 1 '~~> Loop through the cells For i = 15 To lRow If DateDiff("d", .Range("E" & i).Value, Date) > 45 Then If copyRng Is Nothing Then Set copyRng = .Range("B" & i & ":I" & i) Else Set copyRng = Union(copyRng, .Range("B" & i & ":I" & i)) End If End If Next i '~~> Copy the expired records in one go If Not copyRng Is Nothing Then copyRng.Copy .Range("B" & OutputRow) lRow = .Range("B" & .Rows.Count).End(xlUp).Row .Range("I" & OutputRow & ":I" & lRow).Value = "Expired" End If End With End Sub