Extract unique dates given a criteria

[heyviggy]

I have a long list of dates (randomly given), and want to extract unique dates after 01.01.2000 from my list using a macro. So far I got this:

Sub unikeVerdier()
Dim d As Object, c As Variant, i As Long, lr As Long
Set d = CreateObject("Scripting.Dictionary")
lr = Cells(Rows.Count, 1).End(xlUp).Row
c = ActiveWorkbook.Worksheets("Input_raw data").Range("C7:C10006" & lr)
For i = 1 To UBound(c, 1)
d(c(i, 1)) = 1
Next i
ActiveWorkbook.Worksheets("Usage interm.calc.").Range("B90").Resize(d.Count) = Application.Transpose(d.keys)
End Sub

By applying this I get all the unique values returned at B90 in my desired worksheet. The two problems I can't get around right now is:

1) How can I make the macro so the dates comes out sorted?
2) How can I exclude dates before 01.01.2000 from my list of unique values?

Best regards

 

[Worf]

Please test this:

Sub unikeVerdier()
Dim d As Object, c, i As Long, lr&, wb As Workbook, ws As Worksheet


Set wb = ActiveWorkbook
Set ws = wb.Worksheets("Usage")
ws.Range("b89").Value = "Dates" ' header for list
Set d = CreateObject("Scripting.Dictionary")
lr = Cells(Rows.Count, 1).End(xlUp).Row
c = wb.Worksheets("Input").Range("C7:C10006" & lr)
For i = 1 To UBound(c, 1)
    d(c(i, 1)) = 1
Next


ws.Range("B90").Resize(d.Count) = Application.Transpose(d.keys)
lr = ws.Range("b" & Rows.Count).End(xlUp).Row
With ws.Sort
    .SortFields.Clear
    .SortFields.Add Key:=Range("B89"), SortOn:=xlSortOnValues, Order:=1, DataOption:=0
    .SetRange Range("B89:B" & lr)
    .Header = xlYes
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = 1
    .Apply
End With
ws.Range("d89").Value = ""
ws.Range("d90").FormulaR1C1 = "=RC[-2]>36526"   ' 36526 = 1/1/2000
ws.Range("b89:b" & lr).AdvancedFilter xlFilterInPlace, ws.Range("d89:d90"), , True


End Sub

 

[heyviggy]

Worked perfectly, thank you very much!

One small thing though. The rows 90-91 disappears, and the row numbers in the work sheet gets blue. Is this something that can be avoided?

Please test this:

Sub unikeVerdier()
Dim d As Object, c, i As Long, lr&, wb As Workbook, ws As Worksheet


Set wb = ActiveWorkbook
Set ws = wb.Worksheets("Usage")
ws.Range("b89").Value = "Dates" ' header for list
Set d = CreateObject("Scripting.Dictionary")
lr = Cells(Rows.Count, 1).End(xlUp).Row
c = wb.Worksheets("Input").Range("C7:C10006" & lr)
For i = 1 To UBound(c, 1)
    d(c(i, 1)) = 1
Next


ws.Range("B90").Resize(d.Count) = Application.Transpose(d.keys)
lr = ws.Range("b" & Rows.Count).End(xlUp).Row
With ws.Sort
    .SortFields.Clear
    .SortFields.Add Key:=Range("B89"), SortOn:=xlSortOnValues, Order:=1, DataOption:=0
    .SetRange Range("B89:B" & lr)
    .Header = xlYes
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = 1
    .Apply
End With
ws.Range("d89").Value = ""
ws.Range("d90").FormulaR1C1 = "=RC[-2]>36526"   ' 36526 = 1/1/2000
ws.Range("b89:b" & lr).AdvancedFilter xlFilterInPlace, ws.Range("d89:d90"), , True


End Sub

 

[heyviggy]

I managed to get around it, thank you very much for your help!

 

[Worf]

I’m glad it’s working. When advanced filter is used in place, you get the blue row numbers, indicating a filtered range.</SPAN></SPAN>
To avoid that, use the option that copies the result to another location.</SPAN></SPAN>