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 'You can 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
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 'You can 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
No comments:
Post a Comment
Hi User, Thank You for visiting My Blog. Please post your genuine Feedback or comments only related to this Blog Posts. Please do not post any Spam comments or Advertising kind of comments which will be Ignored.