Excel VBA Dynamic Multi-purpose Macro

Macro to define List/Range Names for Each Column with Column headings and then Filter the Unique Records based on a Column['ID'] of the Main Sheet and Copy those Unique Records to Sub Sheet and then Store those Records in an Array and then Sort and Find the Latest records by Date..then Fulfill the Criteria.The Following is a Most Powerful and Dynamic Macro can be used in a efficient manner for various criteria.
Features of This Macro:
> This Macro Defines List/Range Names for Each Column with Column heading as List Name.
>These List Names we can use as dynamic ranges.
>This Macro Filter the Unique Records based on I-Column['ID'] of the Main Sheet and Copy those Unique Records to Sub Sheet ,We can use these Unique records for our criteria building.
>This macro dynamically full fill your requirement based on criteria builded by you.
>The macro is builded in a new and very dynamic approach.

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

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

'My Sample Ranges

Dim ID As Range
Dim Product As Range
Dim Division As Range
Dim Start_Time As Range
Dim Action As Range

Dim MaxDate As String
Dim MinDate As String
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 'For Non Blank Rows Count In Main[Data] Sheet
Dim NBRC_Sub As Long 'For 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("Main").Activate
For X = 1 To CC
If ThisWorkbook.Sheets("Main").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 Division = ThisWorkbook.Names("Division").RefersToRange.Cells
Set Product = ThisWorkbook.Names("Product").RefersToRange.Cells
Set Units = ThisWorkbook.Names("Units").RefersToRange.Cells
Set Price = ThisWorkbook.Names("Price").RefersToRange.Cells
Set Revenue = ThisWorkbook.Names("Revenue").RefersToRange.Cells

'Filtering Data In Main Sheet By ID , Copy Unique ID's and Paste In I-Column of Sub Sheet
ThisWorkbook.Sheets("Main").Activate
ActiveSheet.Range("A1").Select
Selection.AutoFilter
ActiveSheet.Range("ID").AdvancedFilter Action:=xlFilterInPlace, Unique:=True
ActiveSheet.Columns("A:A").Select
Selection.Copy
ThisWorkbook.Sheets("Sub").Activate
ActiveSheet.Range("A1").Select
ActiveSheet.Paste
ActiveSheet.Range("A1").Select
ThisWorkbook.Sheets("Main").Activate
ActiveSheet.Range("A1").Select
Application.CutCopyMode = False
ActiveSheet.ShowAllData
Selection.AutoFilter

'Non Blank Rows Count to Use in our Loops to Reduce Loop TAT [Turn Around Time]For X = 1 To RC
If ThisWorkbook.Sheets("Main").Cells(X, 1) <> "" Then
NBRC_Main = NBRC_Main + 1 'Non Blank Rows Count Based I-Column In Main Sheet
End If
If ThisWorkbook.Sheets("Sub").Cells(X, 1) <> "" Then
NBRC_Sub = NBRC_Sub + 1 'Non Blank Rows Count Based I-Column In Sub Sheet
End If
Next X

' Looping Through Checking Multiple Criteria In  List/Range Names'
For X = 2 To NBRC_Sub 'Youcan Use RC[All Rows Count] But Macro Becomes Very Slow
ReDim MyDate(0)

If ThisWorkbook.Sheets("Sub").Cells(X, 1).value <> "" Then

For Y = 2 To NBRC_Main
If ThisWorkbook.Sheets("Sub").Cells(X, 1).value = ID.Rows(Y).value _
And (Division.Rows(Y).value = "String" Or Division.Rows(Y).value = "Electronic") And _
Product.Rows(Y).value = "Keyboard" Then
ThisWorkbook.Sheets("Sub").Cells(X, 3).value = ThisWorkbook.Sheets("Sub").Cells(X, 3).value + Units.Rows(Y).value

'Reintializing Array SizeMyDate(Z) = Start_Date.Rows(Y).value
Z = Z + 1
'Reintializing Array Size
ReDim Preserve MyDate(Z)
ThisWorkbook.Sheets("Sub").Cells(X, 2).value = Z
End If
Next Y

End If

'Sorting Values Stored In An Array
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

ThisWorkbook.Sheets("Sub").Cells(X, 4).value = MyDate(UBound(MyDate)) 'Maximum Date Value Stored In An Array
ThisWorkbook.Sheets("Sub").Cells(X, 5).value = MyDate(LBound(MyDate) + 1) 'Minimum Date Value Stored In An Array
Z = 0
Next X

Application.DisplayAlerts = True
ThisWorkbook.Sheets("Sub").Activate
End Sub

--------------------------------------------------------------------------------------------------------
Thanks, TAMATAM ; Business Intelligence & Analytics Professional
--------------------------------------------------------------------------------------------------------