Question

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

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（这是如何判断它是否来自拉特年份）。它不是你如何处理它，但它似乎在方法中更简化。另外，我在电子表格中添加了一些日期，并对其进行了测试。只是适用于您的需求。我希望这会有所帮助吗？

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

您可以利用AutoFilter()对象的Range方法并一次性复制/粘贴已过滤的行：

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

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

2 个答案: