Code optimization - Excel VBA Collection and collection sorting

Question

I have an excel sheet with details of employees. I need to display some details on another sheet regarding their years in the company.

The details I want to show are

1. Anniversaries This Month
2. Anniversaries Next Month
3. Anniversaries This Week
4. Anniversaries Next Week
5. Anniversaries Today

I need to show these details with Employee Name, Anniversary Date and Years In Company. Each of these details should be shown in a table with headers and they are in the same columns (B, C and D).

All of this is done by the code below but the sort feature is not working and I need to know whether there is a more effective way of using collection in this case.

Here is the code I have.

Sub PopulateAnniversaryData()
    'Declaring Collections
    Set TodayAnv = New Collection           'collection to store anniversaries today.
    Set ThisWeekAnv = New Collection        'collection to store anniversaries this week.
    Set NextWeekAnv = New Collection        'collection to store anniversaries next week.
    Set CurrentMonthAnv = New Collection    'collection to store anniversaries of current month.
    Set NextMonthAnv = New Collection       'collection to store anniversaries of next month.


    'getting current details
    CurrentDay = Day(Now())                                             'getting current year.
    CurrentMonth = Month(Now())                                         'getting current month.
    CurrentYear = Year(Now())                                           'getting current year.
    CurrentWeek = Application.WorksheetFunction.WeekNum(Now())          'getting the current week number.
    CurrentDate = Year(Now()) & "/" & Month(Now()) & "/" & Day(Now())   'forming current date.

    EmpDetailsLR = LastRowInColumn(1, ED.Name)  'finding the last row in employee details page.
    Dim EmpADate As Date    'declaring a variable to hold employee anniversary date.
    For EmpDetailsFR = 2 To EmpDetailsLR
        JoiningMonth = Month(ED.Range(JoinDateColumnNa & EmpDetailsFR).Value)   'finding employee joining month.
        JoiningDay = Day(ED.Range(JoinDateColumnNa & EmpDetailsFR).Value)       'finding employee joining day.
        JoiningYear = Year(ED.Range(JoinDateColumnNa & EmpDetailsFR).Value)     'finding employee joining year.
        YearsInEY = CurrentYear - JoiningYear                                   'finding number of years employee worked for EY.
        EmpName = ED.Range("C" & EmpDetailsFR).Value                            'finding Employee name.
        EmpJDate = ED.Range(JoinDateColumnNa & EmpDetailsFR).Value              'finding Employee joining date.
        EmpADate = Year(Now()) & "/" & Month(EmpJDate) & "/" & Day(EmpJDate)    'forming employee anniversary date.
        JoiningWeek = Application.WorksheetFunction.WeekNum(EmpADate)           'finding employee joining week.

        If Trim(LCase(ED.Range("H" & EmpDetailsFR).Value)) <> "resigned" And YearsInEY > 0 Then
            'Finding employees with anniversary today.
            If CurrentDate = EmpADate Then _
                TodayAnv.Add Array(EmpName, "Today", YearsInEY)
            'Finding employees with anniversary this week.
            If CurrentWeek = JoiningWeek Then _
                ThisWeekAnv.Add Array(EmpName, WeekDayName(EmpADate), YearsInEY)
            'Finding employees with anniversary next week.
            If CurrentWeek + 1 = JoiningWeek Then _
                NextWeekAnv.Add Array(EmpName, EmpADate, YearsInEY)
            'Finding employees with anniversary this month.
            If CurrentMonth = JoiningMonth Then _
                CurrentMonthAnv.Add Array(EmpName, EmpADate, YearsInEY)
            'Finding employees with anniversary next month.
            If CurrentMonth + 1 = JoiningMonth Then _
                NextMonthAnv.Add Array(EmpName, EmpADate, YearsInEY)
        End If
    Next

    'sorting current month anniversaries based on anniversary date.
    For Collection_Counti = 1 To CurrentMonthAnv.Count - 1
        For Collection_Countj = Collection_Counti + 1 To CurrentMonthAnv.Count
            If CurrentMonthAnv(Collection_Counti)(1) > CurrentMonthAnv(Collection_Countj)(1) Then
                'store the lesser item
                vTemp = CurrentMonthAnv(Collection_Countj)
                'remove the lesser item
                CurrentMonthAnv.Remove Collection_Countj
                're-add the lesser item before the greater Item
                CurrentMonthAnv.Add vTemp(Collection_Counti)
            End If
        Next Collection_Countj
    Next Collection_Counti


    'sorting next month anniversaries based on anniversary date.
    For Collection_Counti = 1 To NextMonthAnv.Count - 1
        For Collection_Countj = Collection_Counti + 1 To NextMonthAnv.Count
            If NextMonthAnv(Collection_Counti)(1) > NextMonthAnv(Collection_Countj)(1) Then
                'store the lesser item
                vTemp2 = NextMonthAnv(Collection_Countj)
                'remove the lesser item
                NextMonthAnv.Remove Collection_Countj
                're-add the lesser item before the greater Item
                NextMonthAnv.Add vTemp2(Collection_Counti)
            End If
        Next Collection_Countj
    Next Collection_Counti

    WriteInRow = 3
    'populating anniversaries this month
    If CurrentMonthAnv.Count <> 0 Then
        AN.Range("B2").Value = "Anniversaries This Month"
        AN.Range("C2").Value = "Date"
        AN.Range("D2").Value = "Years In EY"
        For AnvDic = 1 To CurrentMonthAnv.Count
            AN.Range("B" & WriteInRow).Value = CurrentMonthAnv(AnvDic)(0)
            AN.Range("C" & WriteInRow).Value = CurrentMonthAnv(AnvDic)(1)
            AN.Range("D" & WriteInRow).Value = CurrentMonthAnv(AnvDic)(2)
            WriteInRow = WriteInRow + 1
        Next
        WriteInRow = WriteInRow + 1
    End If

    'populating anniversaries next month
    If NextMonthAnv.Count <> 0 Then
        AN.Range("B" & WriteInRow).Value = "Anniversaries Next Month"
        AN.Range("C" & WriteInRow).Value = "Date"
        AN.Range("D" & WriteInRow).Value = "Years In EY"
        WriteInRow = WriteInRow + 1
        For AnvDic = 1 To NextMonthAnv.Count
            AN.Range("B" & WriteInRow).Value = NextMonthAnv(AnvDic)(0)
            AN.Range("C" & WriteInRow).Value = NextMonthAnv(AnvDic)(1)
            AN.Range("D" & WriteInRow).Value = NextMonthAnv(AnvDic)(2)
            WriteInRow = WriteInRow + 1
        Next
    End If

    'similarly I will populate anniv this week, next week, today etc

    ActiveSheet.Columns.AutoFit
End Sub

Here are the things I would like to know.

1. Is there a better way to do this other than using collection? If so how can it be done? (I prefer not to use anything outside vba capabilities)

2. The sorting feature I have implemented in collection is not working properly and leads to errors. Please suggest a way to use sorting correctly. Provide a code. I am new to collections.

Notes:

1. Some custom functions are used in this code. Don't bother if you see something that is not available in excel by default.

2. My employee details sheet is sorted alphabetically. I want to implement the sort based on anniversary dates.

Answer 1

To make your code clean and manageable, one of the way would be to think Object Oriented way and create Class Module in your VBA Excel.

Example:

Class Module Name : Anniversary

Content:

Public EmployeeName as string
Public EmployeeDate as Date
Public YearsInEY as string

In your Module code, create new object for class and assign the values

Dim oTodayAnniversary as new Anniversary
oTodayAnniversary.EmployeeName = value
oTodayAnniversary.EmployeeDate  = value
oTodayAnniversary.YearsInEY  = value

Use the above collection to print on new sheet.

You can even create single collection, to populate all data, by adding a Enum flag to Anniversary Class module, which will identify the Category type.