Monday, 28 January 2013

How To Find Difference of Maximum and Minimum Dates Using Arrays in Excel VBA

Excel VBA Macro To Find Difference of Maximum and Minimum Dates Using Array
Option Explicit
Sub Arrayz_Dates()
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 Start_Date As Range

Dim End_Date As Range
Dim Max_Start_Date As Range
Dim Min_Start_Date As Range
Dim Difference As Range

Dim MyDate() As Date

Dim TempStr As String

Dim RC As Long 'All Rows Count

Dim CC As Long 'All Columns Count

RC = ThisWorkbook.ActiveSheet.Rows.Count
CC = ThisWorkbook.ActiveSheet.Columns.Count

Set Start_Date = ThisWorkbook.Names("Start_Date").RefersToRange.Cells

Set End_Date = ThisWorkbook.Names("End_Date").RefersToRange.Cells
Set Max_Start_Date = ThisWorkbook.Names("Max_Start_Date").RefersToRange.Cells
Set Min_Start_Date = ThisWorkbook.Names("Min_Start_Date").RefersToRange.Cells
Set Difference = ThisWorkbook.Names("Difference").RefersToRange.Cells
'-------------------------------------------------------------------------------------------------------
Z = 0
' Looping Through Checking Multiple Criteria In  List/Range Names'
For X = 2 To RC 'Youcan Use RC[All Rows Count] But Macro Becomes Very Slow
If Start_Date.Rows(X).value <> "" Then
Z = Z + 1
'Reintializing Array Size
ReDim Preserve MyDate(Z)
MyDate(Z) = Start_Date.Rows(X).value
End If
Next X
'-------------------------------------------------------------------------------------------------------
'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
Max_Start_Date.Rows(2).value = MyDate(UBound(MyDate))
Min_Start_Date.Rows(2).value = MyDate(LBound(MyDate) + 1)
Difference.Rows(2).value = MyDate(UBound(MyDate)) - MyDate(LBound(MyDate) + 1)
End Sub
'-------------------------------------------------------------------------------------------------------

Thanks,
TAMATAM


No comments:

Post a Comment

Follow Me by Email

ExcelKingdom-Popular Posts

ExcelKingdom-Random Posts