How to Find First Occurrence of a String Based On Multiple Criteria

Excel VBA Macro To Know First Occurrence of a String Based On Multiple Criteria
Criteria:

'Suppose If You Have a Data with Ranges as 'ID','Start_Date','Week','Month','End_Date'

'And You Want to find the End_Date[Dead Line] for an ID with Week='Sunday' or 'Monday'

'And This Week Should be the First Occurred week and Should occur only once for the Same ID With Month Names as 'JAN' or 'FEB' or 'MARCH', In Such Cases......This Macro Will Help You.

'Dynamic Multi-Purpose Macro'

Sub MultiCrit_FirstOccur_Macro()
Dim X As Long
Dim Y As Long
Dim Z As Long

Dim I As Long
Dim J As Long
Dim K As Long
Dim LB As Long
Dim UB As Long

Dim A As Long
Dim B As Long

'My Sample Ranges
Dim ID As Object
Dim Week As Object
Dim Month As Object
Dim Start_Date As Object
Dim End_Date As Object
Dim Code As Object

Dim MaxDate As String
Dim MinDate As Date
Dim WSF As WorksheetFunction
Dim MyDate() As Date
Dim TempStr As Date
'------------------------------------------------------------------------------------------
Application.DisplayAlerts = False
Application.ScreenUpdating = False
'------------------------------------------------------------------------------------------
Dim RC As Long 'All Rows Count
Dim CC As Long 'All Columns Count
Dim NBRC_Main As Long 'Non Blank Rows Count In Main[Data] Sheet
Dim NBRC_Sub As Long 'Non Blank Rows Count In Sub[Result] Sheet

RC = ThisWorkbook.ActiveSheet.Rows.Count
CC = ThisWorkbook.ActiveSheet.Columns.Count
'------------------------------------------------------------------------------------------
'Defining Column Headers As List/Range Names for Each Column In Main Sheet
On Error Resume Next
ThisWorkbook.Sheets("Data").Activate
For X = 1 To 50
If ThisWorkbook.Sheets("Data").Cells(1, X) <> "" Then Cells(1, X).EntireColumn.Select
Selection.Name = Cells(1, X).value
Next X
'------------------------------------------------------------------------------------------
'Defining Dynamic Ragne Names
Set ID = ThisWorkbook.Names("ID").RefersToRange.Cells
Set Start_Date = ThisWorkbook.Names("Start_Date").RefersToRange.Cells
Set End_Date = ThisWorkbook.Names("End_Date").RefersToRange.Cells
Set Month = ThisWorkbook.Names("Month").RefersToRange.Cells
Set Week = ThisWorkbook.Names("Week").RefersToRange.Cells
Set Code = ThisWorkbook.Names("Code").RefersToRange.Cells
'------------------------------------------------------------------------------------------
Z = 0
For X = 2 To RC 
If ThisWorkbook.Sheets("Result").Cells(X, 1).value <> "" Then
ReDim MyDate(Z)
For Y = 2 To RC
'Criteria:
'My ID should match to an ID in a Range - ID
'My Month shoud Match to any of 3[JAN or FEB or MARCH] Months of a Range - Month

If ThisWorkbook.Sheets("Result").Cells(X, 1).value = ID.Rows(Y).value And (Month.Rows(Y).value = "JAN" _Or Month.Rows(Y).value = "MAR" Or _
Month.Rows(Y).value = "FEB") Then
'If The Above Criteria Matches Then Store Corresponding Strat_Date Values In Array
MyDate(Z) = Start_Date.Rows(Y).value
Z = Z + 1
'Reintializing Array Size
ReDim Preserve MyDate(Z)
End If
Next Y

End If
'------------------------------------------------------------------------------------------
'Sorting Date Values Stored In An Array to Know Earliest/First Occurance Date
LB = LBound(MyDate)
UB = UBound(MyDate)
    For I = LB To UB - 1
        For J = I + 1 To UB
            If MyDate(I) > MyDate(J) Then
                TempStr = MyDate(J)
                MyDate(J) = MyDate(I)
                MyDate(I) = TempStr
            End If
        Next J
    Next I
    
MinDate = MyDate(LBound(MyDate) + 1) 'Minimu Date Value Stored In An Array
'------------------------------------------------------------------------------------------
If ThisWorkbook.Sheets("Result").Cells(X, 1).value <> "" Then
'Minimum Corresponding Date Of the Matched Criteria
ThisWorkbook.Sheets("Result").Cells(X, 2).value = MyDate(LBound(MyDate) + 1)
'Maximum Corresponding Date Of the Matched Criteria
ThisWorkbook.Sheets("Result").Cells(X, 3).value = MyDate(UBound(MyDate))
End If
'------------------------------------------------------------------------------------------
'Again Looping to Check another Criteria In My Matched Criteria
K = 0
For A = 1 To RC
'Criteria:
'My ID should match to an ID in a Range - ID
'My Week shoud Match to any of 2[Sunday or Monday ] Weeks of a Range - Week
'And  The Week either 'Sunday' or 'Monday' Should Exist For one ID only once

If (ThisWorkbook.Sheets("Result").Cells(X, 1).value = ID.Rows(A).value) And _
(Week.Rows(A).value = "Sunday" Or Week.Rows(A).value = "Monday") Then
K = K + 1 'Count The Matched Criteria Which Should Be 0> and <=2
End If
Next A
'Loop to check whether the Week - 'Sunday' or 'Monday' for the Same ID Occured First and only once.
For B = 1 To RC
If (K <> 0) And (K <= 2) Then
If (ThisWorkbook.Sheets("Result").Cells(X, 1).value = ID.Rows(B).value) And _
(Start_Date.Rows(B).value = MinDate) And (Week.Rows(B).value = "Sunday" Or Week.Rows(B).value = "Monday") Then
ThisWorkbook.Sheets("Result").Cells(X, 4).value = K
ThisWorkbook.Sheets("Result").Cells(X, 5).value = End_Date.Rows(B).value
End If
End If
Next B
Z = 0
Next X
'------------------------------------------------------------------------------------------
Application.DisplayAlerts = True
ThisWorkbook.Sheets("Result").Activate
End Sub

Thanks,TAMATAM