Get All Most Recent Dates per Month in a Single Column VBA

[jazz2409]

Hello, is there another way to get all the most recent dates per month that are in a single column? I am currently using a Pivot Table to do this but if there's a shorter way to do this, I want that :D


Sub GetDates()

Dim rawSh As Worksheet
Dim dncSh As Worksheet
Set rawSh = Worksheets("raw")
Set dncSh = Worksheets("Database")

Set PC = ThisWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:=rawSh.Range("A1").CurrentRegion)
Set pt = PC.CreatePivotTable(TableDestination:=rawSh.Range("R1"))


With pt
.ColumnGrand = False
.RowGrand = False
With .PivotFields("DateOfData")
.Orientation = xlRowField
.Position = 1
.AutoGroup
End With


.AddDataField .PivotFields("DateOfData"), "Count of DateOfData", xlCount


With .PivotFields("Count of DateOfData")
.Caption = "Max of DateOfData"
.Function = xlMax
.NumberFormat = "[$-en-US]d-mmm;@"
End With
End With 'pt

End Sub

Any help is appreciated. Thank you :)

[jazz2409]

Anyone? ��

[paulked]

I think you need to post a workbook of example data

[jazz2409]

Sorry :omg2:

[paulked]

:what: That's just a list of dates!!!!

[jazz2409]

Hmmm I only need to get the max dates per month based on that list.. Am I missing something? :(

[paulked]

Sub GetDates()
Dim ar(), ar1(), ar2(), i&, j&, k&, lr&, yH&, yL&, x&, y&, tm#
tm = Timer
Application.ScreenUpdating = False
lr = Cells(Rows.Count, 1).End(3).Row
ReDim ar(1 To 1, 1 To lr - 1)
ReDim ar1(1 To 3, 1 To 1)
x = 1
Range("a2:a" & lr).Copy Range("Z2")
Range("z2:z" & lr).Sort Range("z2:z" & lr), xlDescending
Range("aa2:aa" & lr) = "=TEXT(RC[-1],""dd/mm/yyyy"")"
ar = Range("aa2:aa" & lr)
yH = Val(Right(ar(LBound(ar), 1), 4))
yL = Val(Right(ar(UBound(ar), 1), 4))
For i = yL To yH
For j = 1 To 12
For k = 1 To lr - 1
If Val(Right(ar(k, 1), 4)) = i And Val(Mid(ar(k, 1), 4, 2)) = j Then
If Val(Left(ar(k, 1), 2)) > ar1(1, x) Then
ar1(1, x) = Val(Left(ar(k, 1), 2))
ar1(2, x) = j
ar1(3, x) = i
y = 1
End If
End If
Next
If y = 1 Then
x = x + 1
ReDim Preserve ar1(1 To 3, 1 To x)
y = 0
End If
Next
Next
For i = 1 To x - 1
ReDim Preserve ar2(1 To 1, 1 To i)
ar2(1, i) = ar1(2, i) & "/" & ar1(1, i) & "/" & ar1(3, i)
Next
Range("z2:aa" & lr) = ""
lr = Cells(Rows.Count, 3).End(xlUp).Row
Range("c2:c" & lr).ClearContents
Range("c2:c" & i).NumberFormat = "[$-en-US]dd-mmm-yy;@"
Range("c2:c" & i) = WorksheetFunction.Transpose(ar2)
Debug.Print Timer - tm
End Sub


This isn't as fast as the pt (0.5secs v 0.3 secs) but it works with different years.

[jazz2409]

Hi Paul, this is exactly what I needed! :clap:
Thank you! :bow:

[paulked]

You're welcome :thumb

[snb]

I'd prefer:


Sub M_snb()
sn = Sheet1.Columns(1).SpecialCells(2)

With CreateObject("scripting.dictionary")
For j = 2 To UBound(sn)
.Item(sn(j, 1)) = .Item(sn(j, 1)) + 1
Next

ReDim st(11, 1)
For Each it In .keys
If .Item(it) > st(Month(it) -1, 0) Then
st(Month(it) -1, 0) = .Item(it)
st(Month(it) -1, 1) = it
End If
Next
End With

Sheet1.Cells(2, 3).Resize(12, 2) = st
End Sub

[paulked]

Like the idea of the dictionary, but it gave me the wrong dates.



160
6-Mar-20


141
3-Apr-20


65
1-May-20

[snb]

Which dates do you prefer ?

Not arrayformula?


=MAX((MONTH($A$2:$A$8000)=3)*$A$2:$A$8000)

[Paul_Hossler]

FWIW, I had to use the OP's macro to make the PT to see exactly how they were defining 'most recent dates'

26620

[paulked]

Yes, a bit confusing at first which is why I asked for a workbook.

[snb]

In that case these formulae suffice:

=MAX((MONTH($A$2:$A$8000)=3)*$A$2:$A$8000)
=MAX((MONTH($A$2:$A$8000)=4)*$A$2:$A$8000)
=MAX((MONTH($A$2:$A$8000)=5)*$A$2:$A$8000)

[Paul_Hossler]

In that case these formulae suffice:

=MAX((MONTH($A$2:$A$8000)=3)*$A$2:$A$8000)
=MAX((MONTH($A$2:$A$8000)=4)*$A$2:$A$8000)
=MAX((MONTH($A$2:$A$8000)=5)*$A$2:$A$8000)


Yes, for the data set given, but what happens when June rolls around, or someone adds January, or there's 2019 or 2021 data?

[snb]

The TS didn't mention, nor some 10000 other unlikely events.