Sunday, 27 January 2013

Excel VBA Dynamic Multipurpose Macro

Excel VBA Dynamic Multi-Purpose Macro
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 Size

MyDate(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
     [ BI-Reporting Analyst ]

No comments:

Post a Comment

Follow Me by Email

ExcelKingdom-Popular Posts

ExcelKingdom-Random Posts