问按日期筛选行(最近7天)

EN

Sub CopyRowWithCurrentDate()

    Dim xRgS As Range, xRgD As Range, xCell As Range
    Dim I As Long, xCol As Long, J As Long
    Dim xVal As Variant

    On Error Resume Next

    Set xRgS = Application.InputBox("Select the Date Column:", "Filter On Date", Selection.Address, , , , , 8)

    If xRgS Is Nothing Then Exit Sub
    Set xRgD = Application.InputBox("Select a destination cell:", "Filter On Date", , , , , , 8)

    If xRgD Is Nothing Then Exit Sub
    xCol = xRgS.Rows.Count
    Set xRgS = xRgS(1)
    Application.CutCopyMode = False

    J = 0
    For I = 1 To xCol
        Set xCell = xRgS.Offset(I - 1, 0)
        xVal = xCell.Value

        If TypeName(xVal) = "Date" And (xVal >= Date - 7) Then
            xCell.EntireRow.Copy xRgD.Offset(J, 0)
            J = J + 1
        End If

    Next

    Application.CutCopyMode = True

End Sub