Macros to Delete Dates not in Current Month

[Jones1413]

Hello,

I am trying to create a macro that will delete all rows of data does not have an anniversary date in the current month.

For example, I would like the macro to search through my sheet to find the last row of data and then delete any row that does not have an anniversary date in the current month(May). Then be able to do the same thing next month, delete any row that does not have an anniversary date in the month of June and so on.

Book1
	A	B
1	Employee ID	Anniversary Date
2	1	4/1/2001
3	2	12/12/1998
4	3	6/15/2004
5	4	9/15/1994
6	5	5/15/2015
7	6	3/20/2009
8	7	5/27/2019
9	8	5/1/2021
10	9	10/13/2013
11	10	6/4/2004
Sheet1

 

[Anthony47]

You don't need a macro for this...
Try inserting this formula in Sheet2-B2 (or any preferred location):

=FILTER(Sheet1!A1:B1000,IFERROR(MONTH(Sheet1!B1:B1000)=MONTH(TODAY()),TRUE))

This assumes the list contains up to 1000 lines; adapt if you have more

 

[offthelip]

try this:

Sub tst()
lastrow = Cells(Rows.Count, "A").End(xlUp).Row
 inarr = Range(Cells(1, 1), Cells(lastrow, 2))
 Range(Cells(2, 1), Cells(lastrow, 2)) = ""
 outarr = Range(Cells(1, 1), Cells(lastrow, 2))
 Cmonth = Month(Now())
 indi = 2
 For i = 2 To lastrow
  If Month(inarr(i, 2)) = Cmonth Then
   outarr(indi, 1) = inarr(i, 1)
   outarr(indi, 2) = inarr(i, 2)
   indi = indi + 1
  End If
 Next i
Range(Cells(1, 1), Cells(indi, 2)) = outarr
End Sub

 

[kevin9999]

Another option. Try it on a copy of your data.

Option Explicit
Sub Jones1413()
    Dim ws As Worksheet
    Set ws = Worksheets("Sheet1")
    Dim LRow As Long, LCol As Long, m As Long, i As Long, a, b
    m = Month(Date)
    LRow = ws.Cells.Find("*", , xlFormulas, , xlByRows, xlPrevious).Row
    LCol = ws.Cells.Find("*", , xlFormulas, , xlByColumns, xlPrevious).Column + 1
    
    a = Range(ws.Cells(2, 2), ws.Cells(LRow, 2))
    ReDim b(1 To UBound(a), 1 To 1)
    For i = 1 To UBound(a)
        If Month(a(i, 1)) <> m Then b(i, 1) = 1
    Next i
    
    ws.Cells(2, LCol).Resize(UBound(a)) = b
    i = WorksheetFunction.Sum(ws.Columns(LCol))
    If i > 0 Then
        ws.Range(ws.Cells(2, 1), ws.Cells(LRow, LCol)).Sort Key1:=ws.Cells(2, LCol), _
        order1:=xlAscending, Header:=xlNo
        ws.Cells(2, LCol).Resize(i).EntireRow.Delete
    End If
End Sub

Before:

Book1
	A	B
1	Employee ID	Anniversary Date
2	1	4/01/2001
3	2	12/12/1998
4	3	6/15/2004
5	4	9/15/1994
6	5	5/15/2015
7	6	3/20/2009
8	7	5/27/2019
9	8	5/01/2021
10	9	10/13/2013
11	10	6/04/2004
Sheet1

After:

Book1
	A	B
1	Employee ID	Anniversary Date
2	5	5/15/2015
3	7	5/27/2019
4	8	5/01/2021
5
Sheet1

 

[Jones1413]

try this:

Sub tst()
lastrow = Cells(Rows.Count, "A").End(xlUp).Row
 inarr = Range(Cells(1, 1), Cells(lastrow, 2))
 Range(Cells(2, 1), Cells(lastrow, 2)) = ""
 outarr = Range(Cells(1, 1), Cells(lastrow, 2))
 Cmonth = Month(Now())
 indi = 2
 For i = 2 To lastrow
  If Month(inarr(i, 2)) = Cmonth Then
   outarr(indi, 1) = inarr(i, 1)
   outarr(indi, 2) = inarr(i, 2)
   indi = indi + 1
  End If
 Next i
Range(Cells(1, 1), Cells(indi, 2)) = outarr
End Sub

This worked great. However, the Anniversary Date is in Column E and my range of data is Column A:F. How would I adjust the above code to account for that?

 

[offthelip]

Very easily done try this:

Sub tst()
lastrow = Cells(Rows.Count, "A").End(xlUp).Row
Lcol = 6    ' Define last column as column 6 (F) or you could use Kevin9999 method
 inarr = Range(Cells(1, 1), Cells(lastrow, Lcol))
 Range(Cells(2, 1), Cells(lastrow, Lcol)) = ""
 outarr = Range(Cells(1, 1), Cells(lastrow, Lcol))
 Cmonth = Month(Now())
 indi = 2
 For i = 2 To lastrow
  If Month(inarr(i, 5)) = Cmonth Then  ' check column 5 (E)
  ' set up loop to copy 6 columns rather that 6 similar statements
   For j = 1 To 6
   outarr(indi, j) = inarr(i, j)
   Next j
   indi = indi + 1
  End If
 Next i
Range(Cells(1, 1), Cells(indi, Lcol)) = outarr
End Sub