Question

我正在寻找在ColumnB中过滤空白单元格的方法，如下所示：

Dim f As Range
Set f = ActiveSheet.Rows(1)
  f.AutoFilter _
    Field:=2, _
    Criteria1:="", _
    VisibleDropdown:=True

如果过滤器中的空白单元格位于两个特定日期之间，我想从那里删除此数据。

日期范围是2019年7月至2020年5月。因此条件将是1过滤空白列b，然后，如果A列和/或c列在2019年7月至2020年5月的日期范围内，则删除过滤的行

谢谢！

Answer 1

我不知道是否有一种使用内置函数来获取所需内容的方法，但是以下代码可以工作。对于大量的行，这可能需要一段时间才能运行。

Public Sub cleanUp()
    Dim sRow As Integer
    Dim lRow As Integer
    Dim rng As Excel.Range
    
    sRow = 2 'set row where data starts
    lRow = ThisWorkbook.Worksheets(1).Cells(1048576, 1).End(xlUp).Row 'find the last row of data
    Set rng = ThisWorkbook.Worksheets(1).Cells(lRow, 2) 'start at the last row with data
    
    For r = lRow To sRow Step -1 'work backwards to avoid skipping rows
        With ThisWorkbook.Worksheets(1)
            If .Cells(r, 2).Value = "" Then
                'column B of row r was empty
                If .Cells(r, 1).Value > 43647 And .Cells(r, 1).Value < 43982 Then
                    'column A of row r was between 1 July 2019 and 31 May 2020
                    'row should be deleted
                    .Rows(r).Delete
                ElseIf .Cells(r, 3).Value > 43647 And .Cells(r, 1).Value < 43982 Then
                    'column C of row r was between 1 July 2019 and 31 May 2020
                    'row should be deleted
                    .Rows(r).Delete
                Else
                    'dates in columns A and C did not match criteria
                    'do nothing
                End If
            Else
                'column B of row r is not empty
                'do nothing
            End If
        End With
    Next r
    
End Sub

Answer 2

之内

假设

日期是日期，而不是字符串。
Within July 2019 to May 2020的意思是07/01/2019 00:00:00 <= n < 06/01/2020 00:00:00。
数据集下方没有数据。

用法和提示

将完整代码复制到标准模块中，例如Module1。
仅运行第一个过程（deleteWithin），其余过程将在必要时被其调用。
已根据您的设置调整了常量，但是请在运行代码之前检查常量。
您应该使工作表（也可能是工作簿）合格。您不想在错误的工作表上运行此代码。
首先使用Select（在deleteRows中进行调整）测试代码的准确性，然后再更改为Delete。

代码

Option Explicit

Sub deleteWithin()
    
    ' Constants
    
    Const FirstMMMMYYYY As String = "July 2019"
    Const LastMMMMYYYY As String = "May 2020"
    Const FirstRow As Long = 2        ' First Row of Data
    Const Cols As String = "A:C"      ' Address of All Columns
   ' The following 4 column numbers represent the n-th columns of 'Cols'.
    Const LastRowColumn As Long = 1   ' Column to Calculate the Last Row
    Const DateColumn1 As Long = 1     ' Column Containing the First Date.
    Const DateColumn2 As Long = 3     ' Column Containing the Second Date.
    Const CriteriaColumn As Long = 2  ' Column Containing the Criteria ("")
    Const Criteria As String = ""
    
    ' Define Source Range ('rng').
    
    Dim ws As Worksheet
    Set ws = ActiveSheet
    Dim rng As Range
    Set rng = ws.Columns(LastRowColumn).Find("*", , xlFormulas, , , xlPrevious)
    If rng Is Nothing Then
        GoTo ProcExit
    End If
    If rng.Row < FirstRow Then
        GoTo ProcExit
    End If
    Dim FirstColumn As Long
    FirstColumn = ws.Columns(Cols).Column
    Dim LastColumn As Long
    LastColumn = FirstColumn + ws.Columns(Cols).Columns.Count - 1
    Set rng = ws.Range(ws.Cells(FirstRow, FirstColumn), _
                       rng.Offset(, LastColumn - LastRowColumn))
    
    ' Write the numbers of the rows to delete to Data Rows Array ('DataRows').
    
    ' Write values from Source Range to Data Array ('Data').
    Dim Data As Variant
    Data = rng.Value
    ' Define Data Rows Array.
    Dim DataRows As Variant
    ReDim DataRows(1 To UBound(Data))
    ' Calculate Date Interval ('DateInterval').
    Dim DateInterval As Variant
    DateInterval = getDateInterval(FirstMMMMYYYY, LastMMMMYYYY)
    ' Declare additional variables to use in the following 'For Next' loop.
    Dim FirstDate As Variant
    Dim SecondDate As Variant
    Dim i As Long
    Dim k As Long
    ' Loop through rows of Data Array.
    For i = 1 To UBound(Data)
        ' If Criteria is found then write row number to Data Rows Array.
        If Data(i, CriteriaColumn) = Criteria Then
            FirstDate = Data(i, DateColumn1)
            SecondDate = Data(i, DateColumn2)
            If fallsWithin(FirstDate, SecondDate, DateInterval) Then
                k = k + 1
                DataRows(k) = i + FirstRow - 1
            Else
            End If
        End If
    Next i
    
    ' Delete rows in worksheet.
    
    ' Check if at least once Criteria was found.
    If k > 0 Then
        ' Resize Data Rows Array.
        ReDim Preserve DataRows(1 To k)
        ' Delete rows in one go.
        deleteRows ws, DataRows
        MsgBox "Rows deleted."
    Else
        MsgBox "Nothing deleted."
    End If
   
ProcExit:
End Sub

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Converts two strings in the format "MMMM YYYY" to dates and
' returns a 1D two-element array whose first element is less than
' the second element. The first element is to be tested with ">=", while
' the second element is to be tested with "<".
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function getDateInterval(ByVal FirstMMMMYYYY As String, _
                         ByVal SecondMMMMYYYY As String) _
         As Variant
    
    Dim MMMM As Variant
    MMMM = Array("January", "February", "March", "April", "May", "June", _
                "July", "August", "September", "October", "November", _
                "December")
    Dim First As Date
    First = DateSerial(CLng(Split(FirstMMMMYYYY)(1)), _
                       Application.Match(Split(FirstMMMMYYYY)(0), MMMM, 0), _
                       1)
    Dim Second As Date
    Second = DateSerial(CLng(Split(SecondMMMMYYYY)(1)), _
                        Application.Match(Split(SecondMMMMYYYY)(0), MMMM, 0) _
                        + 1, _
                        1)
    If First < Second Then
        getDateInterval = Array(First, Second)
    Else
        getDateInterval = Array(Second, First)
    End If
    
End Function

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Returns 'True' if two values are within the values of an interval.
' The interval is a 1D two-element array and its first element
' is less than its second element. The first element is to be tested with ">=",
' while the second element is to be tested with "<".
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function fallsWithin(ByVal FirstValue As Variant, _
                     ByVal SecondValue As Variant, _
                     Interval As Variant) _
         As Boolean
    
    Dim StartValue As Variant
    StartValue = Interval(LBound(Interval))
    Dim EndValue As Variant
    EndValue = Interval(UBound(Interval))
    If FirstValue < SecondValue Then
        If FirstValue >= StartValue And SecondValue < EndValue Then
            fallsWithin = True
        End If
    Else
        If SecondValue >= StartValue And FirstValue < EndValue Then
            fallsWithin = True
        End If
    End If

ProcExit:

End Function

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Assumes that 'Sheet' is a valid worksheet and 'Data' is a 1D array
' containing at least one row number.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub deleteRows(Sheet As Worksheet, _
               DataRows As Variant)
    Dim rng As Range
    Set rng = Sheet.Rows(DataRows(LBound(DataRows)))
    If UBound(DataRows) - LBound(DataRows) > 0 Then
        Dim j As Long
        For j = LBound(DataRows) + 1 To UBound(DataRows)
            ' 'Collect' row ranges into one range.
            Set rng = Union(rng, Sheet.Rows(DataRows(j)))
        Next j
    End If
    ' Delete rows in one go.
    rng.Select ' Change to 'rng.Delete' when tested.
End Sub

根据日期范围删除过滤数据

2 个答案:

之内