我的自动筛选器突然停止使用日期列范围

时间:2019-07-31 19:03:46

标签: vba

我有一个报告需要在今天的日期和前四天之间进行过滤,该行在此行中工作得很好:

格式完全没有改变,所以这不是问题

.Range("A1:A" & Range("AR" & Rows.Count).End(xlUp).Row).AutoFilter Field:=19, Criteria1:=">=" & CLng(Date - 4)

但是现在它根本不起作用,它不会自动过滤任何内容。根本没有任何改变,只是添加了不同数量的行。

有人知道为什么会这样吗?我乐于将其定义为数组和循环,但是在开始时需要一些帮助。有解决这个问题的经验吗?

其余代码:

Sub LOBEligibilityTermCheck()

    Dim SrcWB As Workbook
    Dim SrcWS As Worksheet
    Dim TgtWS As Worksheet
    Dim i As Long
    Dim rngTemp As Range

    Workbooks.Open ("C:\Final Terms.xlsx")
    Workbooks.Open ("C:\daily-report.xlsx")

    Set SrcWB = Workbooks("Final Terms.xlsx")
    Set TgtWB = Workbooks("daily-report.xlsx")
    Set SrcWS = SrcWB.Sheets("Sheet1")
    Set TgtWS = TgtWB.Sheets(1)

    Application.ScreenUpdating = False

    If WorksheetIsOpen("Final Terms.xlsx", "Sheet1") = False Then
        MsgBox "This macro requires the term file to be open prior to running." & vbNewLine & vbNewLine _
            & "The file name MUST be 'Final Terms .xlsx' and the list MUST be in a worksheet (tab) titled 'Sheet1'." _
            & vbNewLine & vbNewLine & "Please open the file and run the macro again.", vbOKOnly, "Error"
        Exit Sub
    End If

    With TgtWS
        .Rows(1).EntireRow.Delete
        .Rows(1).EntireRow.Delete
        i = .Columns("C:D").Find(what:="*", searchdirection:=xlPrevious, searchorder:=xlByRows).Row
        On Error Resume Next
        With .Range("C2:C" & i)
            .SpecialCells(xlCellTypeBlanks).Formula = "=rc[1]"
            .Value = .Value
        End With
        .Columns("D").EntireColumn.ClearContents
        .Range("s2", "s10000").NumberFormat = "m/d/y"
        .Cells(1, 4) = "Unique Identifier"
        .Range("A1:A" & Range("AR" & Rows.Count).End(xlUp).Row).AutoFilter Field:=19, Criteria1:=">=" & CLng(Date - 1)

        lastrowlob = LastRowIndex(TgtWS, 1)
        If lastrowlob < 2 Then lastrowlob = 2

        .Cells(1, 4) = "Unique Identifier"
        .Range(Cells(2, 4), Cells(lastrowlob, 4)).SpecialCells(xlCellTypeVisible).FormulaR1C1 = _
            "=trim(rc[-3]&right(rc[-1],4))"

        .Columns("E").Insert
        .Cells(1, 5) = "Eligibility Lookup"
        .Range(.Cells(2, 5), .Cells(lastrowlob, 5)).SpecialCells(xlCellTypeVisible).FormulaR1C1 = _
            "=IFNA(INDEX('[Final Terms.xlsx]Sheet1'!C13,MATCH(RC[-1],'[Final Terms.xlsx]Sheet1'!C13,0)),"""")"
        .Rows(1).EntireRow.AutoFilter
        .Range("E:E").Copy
        .Range("E:E").PasteSpecial xlPasteValues

        .Range("$A$1:$AO$" & lastrowlob).AutoFilter Field:=5, Criteria1:="<>", Operator:=xlAnd
        .Range("A2").Select

        ActiveWindow.ScrollRow = 1

            On Error Resume Next
            Set rngTemp = .Range(.Cells(2, 5), .Cells(lastrowlob, 5)).SpecialCells(xlCellTypeVisible)
            On Error GoTo 0

            If rngTemp Is Nothing Then
                i = 0
            Else
                i = rngTemp.Cells.Count
            End If

            If i > 0 Then
                MsgBox "Found " & i & " term(s).", vbOKOnly, "Results"
            Else
                MsgBox "No terms found"
                .Rows(1).EntireRow.AutoFilter
                .Range("A2").Select
            End If
    End With
    SrcWB.Close savechanges = False

    Application.ScreenUpdating = True

End Sub

0 个答案:

没有答案