Within
Assumptions
- The dates are dates, not strings.
Within July 2019 to May 2020 means 07/01/2019 00:00:00 <= n < 06/01/2020 00:00:00.- There is no data below the dataset.
Usage & Tips
- Copy the complete code into a standard module, e.g.
Module1.
- Only run the first procedure (
deleteWithin), the rest of them are being called by it, when necessary.
- The constants are adjusted to your setup, but check them before running the code.
- You should qualify the worksheet, probably the workbook, too. You would't want to run this code on the wrong worksheet.
- Test the accuracy of the code first with
Select (adjusted in deleteRows) and only afterwards change to Delete.
The Code
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
