将单元格移动到最后一行而不会擦除现有的

Question

以下代码检查主页上的任何行是否包含一年前或更早的日期。如果确实如此，它会将其复制到“存档”工作表并从主页面中删除它。但是，它现在所做的只是从主页面复制并覆盖存档页面上已存在的内容，而不是添加到最后一行。我从LastRow函数中尝试了Subbing，但是我在使用它时遇到了错误。任何人有更好的解决方案？

Sub TestDateTransfer() 
With Application 
PrevCalc = .Calculation 
.Calculation = xlCalculationManual 
.Cursor = xlWait 
.Calculate 
.EnableEvents = False 
.ScreenUpdating = False 
End With 
Application.DisplayAlerts = False 
Worksheets("Archive").Activate 
Range("A3:I1000").Select 
Selection.ClearContents 
Worksheets("Main Page").Activate 
Dim MyDate As Date 
MyDate = "03/27/2017" 
Set i = Sheets("Main Page") 
Set E = Sheets("Archive") 
Dim d 
Dim j 
d = 2 
j = 2 

Do Until IsEmpty(i.Range("C" & j)) 

    If i.Range("C" & j) <= MyDate - 365 Then 
    d = d + 1 
    E.rows(d).Value = i.rows(j).Value 

    End If 
    j = j + 1 
Loop 
Worksheets("Archive").Activate 
ActiveSheet.Range("H1").Select 'To unselect the page 
Worksheets("Main Page").Activate 
MyDate = "03/27/2017" 
Dim y 
Dim z 
y = 2 
z = 2 
Do Until IsEmpty(i.Range("C" & z)) 

    If i.Range("C" & z) <= MyDate - 365 Then 
    y = y + 1 
    i.rows(z).Delete 

    End If 
    z = z + 1 
    Loop 
With Application 
.Cursor = xlDefault 
.Calculate 
.Calculation = PrevCalc 
'.ScreenUpdating = True 'Not Needed... 
.EnableEvents = True 
End With 
ActiveSheet.Range("H1").Select 
End Sub 

Answer 1

Worksheets("Archive").Cells(Sheet1.Rows.Count, 1).End(xlUp).Offset(1, 0).Value = "hai" 

我写了一个小的一段代码，展示了如何使用这个。我的代码与你的b/c不同，它在整个范围内循环，并检查每个单元格，如果它与NOW之间的差值大于或等于1（这是如何判断它是否来自lats year）。它不是你如何处理它，但它似乎在方法中更简化。此外，我还在电子表格中填入了日期，并对此进行了测试。只是适用于您的需求。我希望这有助于更多？

Private Sub this() 
    Dim rng As Range 
    Dim rcell As Range 

    Set rng = ThisWorkbook.Sheets("Sheet1").Range("A1:A20") 

    For Each rcell In rng.Cells 
     'note that if you dont put a handler in here to deal with blank cells values this code will run forever. most peop-le do a check with "if rcell.valeu <> vbNullString then etc etc 
     If DateDiff("yyyy", rcell.Value, Now()) >= 1 Then 
      Worksheets("Sheet2").Cells(Sheet2.Rows.Count, 1).End(xlUp).Offset(1, 0).Value = rcell.Value 
      rcell.Value = vbNullString 
     End If 
    Next rcell 
End Sub 

Answer 2

你可以在一杆利用方法对象和复制/粘贴过滤行RangeAutoFilter()：

Option Explicit 

Sub main() 
    Dim MyDate As Date 
    MyDate = "03/27/2017" 

    Dim E As Worksheet 
    Set E = Worksheets("Archive") 

    With Worksheets("Main Page") 
     With .Range("C1", .Cells(.Rows.Count, "C").End(xlUp)) 
      .AutoFilter field:=1, Criteria1:="<=" & CDbl((MyDate - 365)) 
      If Application.WorksheetFunction.Subtotal(103, .Cells) > 1 Then Intersect(.Parent.UsedRange, .Resize(.Rows.Count - 1).Offset(1).SpecialCells(xlCellTypeVisible).EntireRow).Copy Destination:=E.Cells(Rows.Count, 1).End(xlUp).Offset(1) 
     End With 
     .AutoFilterMode = False 
    End With 
End Sub