have a bit of a tricky one. I have a range of data that i am using
to produce reports. One of these reports relates to column m. This
range has various dates in each cell. These dates are in the past and
future. What the reports needs to do is identify the first 3 dates in
the range that are over todays date and report how many times these
dates appear in the range, for instance

the range may include


feb 12
feb 20
mar 01
mar 01
april 01
april 01
april 10
may 05
may 05


the results would be mar01 = 2 april 01 = 2 april 10 =1


the reports ignores may 05 as its the fourth furthest date in the
future

I have this codes that works great and displays the dates in a message
box, i would like to know how to adapt this to put the three dates and
three totals into seperate cells

Sub EFG()
Dim oDict As Object
Set oDict = CreateObject("scripting.dictionary")
Dim rng As Range, cell As Range
Dim v As Variant, v1 As Variant
Dim i As Long, j As Long, temp As Variant
Dim msg As String
Set rng = Range(Cells(1, "M"), Cells(1, "M").End(xlDown))
On Error Resume Next
For Each cell In rng
If cell.Value Date Then
If Not oDict.Exists(Format(cell.Value, _
"mm/dd/yyyy")) Then
oDict.Add Format(cell.Value, "mm/dd/yyyy"), _
cell.Value
End If
End If
Next
v = oDict.Keys
v1 = oDict.Items
For i = LBound(v1) To UBound(v1) - 1
For j = i + 1 To UBound(v1)
If v1(i) v1(j) Then
temp = v1(i)
v1(i) = v1(j)
v1(j) = temp
End If
Next
Next
msg = ""
For i = LBound(v1) To LBound(v1) + 2
msg = msg & Format(v1(i), "mm/dd/yyyy") & " " & _
Application.CountIf(rng, v1(i)) & vbNewLine
Next
MsgBox msg

End Sub

Sub EFG()
Dim oDict As Object
Set oDict = CreateObject("scripting.dictionary")
Dim rng As Range, cell As Range
Dim v As Variant, v1 As Variant
Dim i As Long, j As Long, temp As Variant
Dim msg As String
Set rng = Range(Cells(1, "M"), Cells(1, "M").End(xlDown))
On Error Resume Next
For Each cell In rng
If cell.Value Date Then
If Not oDict.Exists(Format(cell.Value, _
"mm/dd/yyyy")) Then
oDict.Add Format(cell.Value, "mm/dd/yyyy"), _
cell.Value
End If
End If
Next
v = oDict.Keys
v1 = oDict.Items
For i = LBound(v1) To UBound(v1) - 1
For j = i + 1 To UBound(v1)
If v1(i) v1(j) Then
temp = v1(i)
v1(i) = v1(j)
v1(j) = temp
End If
Next
Next
msg = ""
For i = LBound(v1) To LBound(v1) + 2
cells(i,"S").Value = v1(i)
cells(i,"S").NumberFormat = "mmm dd"
cells(i,"T").Formula = "=Countif(M:M,""=" & v1(i) _
& """)"
Next
End Sub

--
Regards,
Tom Ogilvy

wrote in message
oups.com...
have a bit of a tricky one. I have a range of data that i am using
to produce reports. One of these reports relates to column m. This
range has various dates in each cell. These dates are in the past and
future. What the reports needs to do is identify the first 3 dates in
the range that are over todays date and report how many times these
dates appear in the range, for instance

the range may include


feb 12
feb 20
mar 01
mar 01
april 01
april 01
april 10
may 05
may 05


the results would be mar01 = 2 april 01 = 2 april 10 =1


the reports ignores may 05 as its the fourth furthest date in the
future

I have this codes that works great and displays the dates in a message
box, i would like to know how to adapt this to put the three dates and
three totals into seperate cells

Sub EFG()
Dim oDict As Object
Set oDict = CreateObject("scripting.dictionary")
Dim rng As Range, cell As Range
Dim v As Variant, v1 As Variant
Dim i As Long, j As Long, temp As Variant
Dim msg As String
Set rng = Range(Cells(1, "M"), Cells(1, "M").End(xlDown))
On Error Resume Next
For Each cell In rng
If cell.Value Date Then
If Not oDict.Exists(Format(cell.Value, _
"mm/dd/yyyy")) Then
oDict.Add Format(cell.Value, "mm/dd/yyyy"), _
cell.Value
End If
End If
Next
v = oDict.Keys
v1 = oDict.Items
For i = LBound(v1) To UBound(v1) - 1
For j = i + 1 To UBound(v1)
If v1(i) v1(j) Then
temp = v1(i)
v1(i) = v1(j)
v1(j) = temp
End If
Next
Next
msg = ""
For i = LBound(v1) To LBound(v1) + 2
msg = msg & Format(v1(i), "mm/dd/yyyy") & " " & _
Application.CountIf(rng, v1(i)) & vbNewLine
Next
MsgBox msg

End Sub

thanks again tom but its now only showing the first two dates, any
ideas

John

Here is a fix:

Sub EFG()
Dim oDict As Object
Set oDict = CreateObject("scripting.dictionary")
Dim rng As Range, cell As Range
Dim v As Variant, v1 As Variant
Dim i As Long, j As Long, temp As Variant
Dim msg As String
Set rng = Range(Cells(1, "M"), Cells(1, "M").End(xlDown))
On Error Resume Next
For Each cell In rng
If cell.Value Date Then
If Not oDict.Exists(Format(cell.Value, _
"mm/dd/yyyy")) Then
oDict.Add Format(cell.Value, "mm/dd/yyyy"), _
cell.Value
End If
End If
Next
v = oDict.Keys
v1 = oDict.Items
For i = LBound(v1) To UBound(v1) - 1
For j = i + 1 To UBound(v1)
If v1(i) v1(j) Then
temp = v1(i)
v1(i) = v1(j)
v1(j) = temp
End If
Next
Next
msg = ""
j = 1
For i = LBound(v1) To LBound(v1) + 2
cells(j,"S").Value = v1(i)
cells(j,"S").NumberFormat = "mmm dd"
cells(j,"T").Formula = "=Countif(M:M,""=" & v1(i) _
& """)"
j = j + 1
Next
End Sub


--
Regards,
Tom Ogilvy

wrote in message
oups.com...
thanks again tom but its now only showing the first two dates, any
ideas

John