Excel VBA，将数据从一个工作表复制并粘贴到另一个工作表，然后删除复制数据源

Question

我很难创建一个宏，它将一行数据从一个工作表复制到另一个工作表，然后立即删除复制的数据源并向上移动下面的行以清除剩余的空白/空行。此工作簿的上下文是一个请求跟踪器，一旦请求具有完成日期，在一定时间段（30 天）后，该请求将被复制到“历史请求”表中。紧接着，活动页面上的原始复制数据将被删除，其他所有内容都“向上移动”以清除留下的空白。这是我已经开发的，当然还有一些帮助......如果有人可以提供帮助，将不胜感激。

Public Sub DataBackup()
Dim RowDate
Dim CurrentDate
Dim Interval
Dim CurrentAddress
Dim ValueCellRange As Range
Dim ValueCell As Range
Dim ws As Worksheet

'Interval set to an appropriate number of days
Interval = 30
CurrentDate = Now()

For Each ws In Worksheets
    Set ValueCellRange = ws.Range("U3:U130")
    For Each ValueCell In ValueCellRange
        If ValueCell.Value <> "" Then
            If CurrentDate - ValueCell.Value >= Interval Then

                Rows(ActiveCell.Row).Select

                Sheets("Historical Requests").Select
                ActiveSheet.Paste

                ValueCell.EntireRow.ClearContents
            End If
        End If
    Next ValueCell
Next ws

'Clear variable value for next initialization
Set ValueCell = Nothing



End Sub

Answer 1

您确实投入了工作。正如 BruceWayne 建议的那样，您的代码还不错，但可以使用更少的选择和更少的激活。您无需选择或激活工作表或范围即可使用它。这是更高效的代码，我认为其他许多代码可以使其更高效。

顺便说一句，在删除行时，尝试始终从下往上工作。并确保“H”列被格式化为日期，否则这不起作用。

Sub copyCut()
Dim ws_DATA As Worksheet, ws_HISTORY As Worksheet
Dim lastRowHISTORY As Long

Set ws_DATA = Sheet3'   Change this sheet to match your correct one
Set ws_HISTORY = Worksheets(4)' Change this sheet to match your correct one


For i = 130 To 3 Step -1
    On Error Resume Next
    lastRowHISTORY = ws_HISTORY.Cells.Find(What:="*", _
                    After:=Range("A1"), _
                    LookAt:=xlPart, _
                    LookIn:=xlFormulas, _
                    SearchOrder:=xlByRows, _
                    SearchDirection:=xlPrevious, _
                    MatchCase:=False).Row + 1
    If Err.Number = 91 Then lastRowHISTORY = 1
    On Error GoTo 0

    If Now - DateValue(ws_DATA.Range("U" & i).Value) > 29 Then
        ws_DATA.Range("U" & i).EntireRow.Copy Destination:=ws_HISTORY.Range("A" & lastRowHISTORY)
        ws_DATA.Range("U" & i).EntireRow.Delete
    End If
Next i
Set ws_DATA = Nothing
Set ws_HISTORY = Nothing

End Sub

Answer 2

要遍历所有四张纸，只需在脚本中添加一个“for 1 = n to 4”循环。我能预见的唯一问题是所有四个页面的行数是否不同。如果它们不是全部 130，则可以轻松修复。请告诉我。只需要代码就可以找到每张纸上最后使用的行。

    Sub copyCut()
    Dim ws_DATA As Worksheet, ws_HISTORY As Worksheet
    Dim lastRowHISTORY As Long

    Set ws_DATA = Sheet3'   Change this sheet to match your correct one
    Set ws_HISTORY = Worksheets(4)' Change this sheet to match your correct one

    For n = 1 to 4

    Select Case n
         Case 1
             Set ws_DATA = Worksheets("Sheet1")' change these to your sheet names
         Case 2 
             Set ws_DATA = Worksheets("Sheet2")
         Case 3 
             Set ws_DATA = Worksheets("Sheet3")
         Case 4 
             Set ws_DATA = Worksheets("Sheet4")

    End Select 

    For i = 130 To 3 Step -1
        On Error Resume Next
        lastRowHISTORY = ws_HISTORY.Cells.Find(What:="*", _
                        After:=Range("A1"), _
                        LookAt:=xlPart, _
                        LookIn:=xlFormulas, _
                        SearchOrder:=xlByRows, _
                        SearchDirection:=xlPrevious, _
                        MatchCase:=False).Row + 1
        If Err.Number = 91 Then lastRowHISTORY = 1
        On Error GoTo 0

        If Now - DateValue(ws_DATA.Range("U" & i).Value) > 29 Then
            ws_DATA.Range("U" & i).EntireRow.Copy Destination:=ws_HISTORY.Range("A" & lastRowHISTORY)
            ws_DATA.Range("U" & i).EntireRow.Delete
        End If
    Next i


Next n

Set ws_DATA = Nothing
Set ws_HISTORY = Nothing

End Sub