Verschieben von Zellen in die letzte Zeile, ohne das vorhandene zu löschen

Question

Der folgende Code überprüft, ob eine Zeile auf der Hauptseite ein Datum von vor einem Jahr enthält. Wenn dies der Fall ist, kopiert es es in das Arbeitsblatt "Archiv" und löscht es von der Hauptseite. Was es jetzt tut, ist jedoch nur Kopieren von der Hauptseite und Überschreiben, was bereits auf der Archivseite vorhanden ist, anstatt zur letzten Zeile hinzuzufügen. Ich habe versucht, in LastRow von einer Funktion subbing, aber ich bekam einen Fehler mit wie ich es benutze. Hat jemand eine bessere Lösung?

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" 

Ich habe ein kleines Stück Code geschrieben, das Ihnen zeigt, wie diese verwenden. Mein Code ist anders als Ihr b/c es durchläuft den Bereich und überprüft jede Zelle, wenn der Wert der Differenz zwischen ihm und NOW größer als oder gleich 1 ist (was ist zu sagen, ob es von Lats Jahr oder nicht). Es ist nicht so, wie Sie es angehen, aber es scheint in dem Ansatz einfacher zu sein. Außerdem habe ich eine Reihe von Daten in einer Tabelle gespeichert und getestet. wenden Sie sich einfach an Ihre Bedürfnisse. Ich hoffe, das hilft mehr?

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

Sie könnten AutoFilter() Methode von Range Objekt und Kopieren/Einfügen gefilterten Zeilen in einem Schuss ausnutzen:

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