VBA Code to get unique and update Validation

[Sahil123]

Hi All,

Im hoping you can help me this.

I have a sheet called Index..On that sheet I have a table called RawData with a Date Range.

Each day This Date column gets filled in and that column will have duplicate dates in there as I update this column several times for each team.

I have a separate heading called DailyDates, WeeklyDates, MonthlyDates across G1:I1 and a data validation in J1.I have this data validation formula in J1...
=IF($B$1=1,DailyDates,IF($B$1=2,WeeklyDates,MonthlyDates))

What I want to do is get a unique list of dates for daily dates from the date range and then for the week get the Monday date for that week so that the week should always have a Mondays Date. In the Month Section it should have the unique month from the daily date range. Once this has been, I want to populate the data validation which should pick up the right named range..

I really hope this makes sense

This is what it should look like

Table names - RawData

Dates	Team
15/09/2016	Team1
15/09/2016	Team2
15/09/2016	Team3
15/09/2016	Team4
15/09/2016	Team5
16/09/2016	Team1
16/09/2016	Team2
16/09/2016	Team3
16/09/2016	Team4
16/09/2016	Team5
19/09/2016	Team1
19/09/2016	Team2
19/09/2016	Team3
19/09/2016	Team4
19/09/2016	Team5
20/09/2016	Team1
20/09/2016	Team2
20/09/2016	Team3
20/09/2016	Team4
20/09/2016	Team5

<tbody>
</tbody>

DailyDates	WeeklyDates	MonthlyDates
15/09/2016	12/09/2016	Sep 16
16/09/2016	19/09/2016
19/09/2016

<tbody>
</tbody>

The DataValidation should then pick up the correct named dynamic range depending on what option was selected

 

[Sahil123]

Sorry WC means week commencing- so the Mondays date (so if say i had daily dates, 7,8,9 of September - there should be a date 05/09 in the weeklydates..
if i had 14,15,16 of September, that means im still in the current week so the monday (12 of sept) should not be added to the week dates yet..when i run the code on monday (19/09) i should then be adding the week date 12/09 and the daily date of 19/09 will be added as normal to the daily date range..

Is that more clearer Buddy?

Not sure what you mean by Idem?

the same logic as the week dates should be applied to the month range..So if im in the current month, the current should not be added until the next month..

The named ranges, are they being modified or would i need to delete the named range because they already exist?

 

[Sahil123]

It looks to be working fine but the current week date or current month date should not be added until following week or month ..so in your example the week dates and month dates will be blank..

 

[Marcelo Branco]

It looks to be working fine but the current week date or current month date should not be added until following week or month ..so in your example the week dates and month dates will be blank..

The code does exactly what you asked for in post#1. The text in red (above) seems to me as a new requirement.

No problem, but would be helpful if you could provide a new data sample and expected/desired results accordingly to this new requirement.

Idem = the same

M.

 

[Marcelo Branco]

See if this new version is OK

Sub aTestV2()
    'New version with two new Requirements:
    '1.Date WeekNum must be less than Current WeekNum
    '2.Date Month must be less than Current Month
    'REMARK: considers first day of week = Monday
    Dim dictDay As Object, dictWeek As Object, dictMonth As Object
    Dim rcell As Range, v As Variant
    
    Set dictDay = CreateObject("Scripting.Dictionary")
    Set dictWeek = CreateObject("Scripting.Dictionary")
    Set dictMonth = CreateObject("Scripting.Dictionary")
    
    With Sheets("Index")
        For Each rcell In .Range("A2:A" & .Cells(.Rows.Count, "A").End(xlUp).Row)
            dictDay(rcell.Value2) = Empty
            
            'Check if WeekNum is less than current WeekNum
            If rcell < Date - Weekday(Date, 2) + 1 Then
                dictWeek(rcell.Value2 - Weekday(rcell.Value2, vbMonday) + 1) = Empty
            End If
            
            'Check if month is less than current month
            If rcell <= Application.EoMonth(Date, -1) Then
                dictMonth(CLng(DateSerial(Year(rcell.Value2), Month(rcell.Value2), 1))) = Empty
            End If
            
        Next rcell
        
        .Columns("G:I").ClearContents
        .Range("G1:I1").Value = Array("DailyDates", "WeeklyDates", "MonthlyDates")
        
        With .Range("G2").Resize(dictDay.Count)
            .Value = Application.Transpose(dictDay.keys)
            .Name = "DailyDates"
            .NumberFormat = "dd/mm/yyyy"
        End With
            
        If dictWeek.Count Then
            With .Range("H2").Resize(dictWeek.Count)
                .Value = Application.Transpose(dictWeek.keys)
                .Name = "WeeklyDates"
                .NumberFormat = "dd/mm/yyyy"
            End With
        End If
        
        If dictMonth.Count Then
            With .Range("I2").Resize(dictMonth.Count)
                .Value = Application.Transpose(dictMonth.keys)
                .Name = "MonthlyDates"
                .NumberFormat = "mmm yy"
            End With
        End If
        
        .Columns("G:I").AutoFit
        
        With .Range("J1")
            With .Validation
                .Delete
                .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
                 xlBetween, Formula1:="=if($L$1=1,DailyDates,If($L$1=2,WeeklyDates,MonthlyDates))"
                .IgnoreBlank = True
                .InCellDropdown = True
                .InputTitle = ""
                .ErrorTitle = ""
                .InputMessage = ""
                .ErrorMessage = ""
                .ShowInput = True
                .ShowError = True
            End With
            .NumberFormat = "dd/mm/yyyy"
            .ColumnWidth = 10
        End With
    End With
        
End Sub

M.

 

[Marcelo Branco]

Try this new version - i had to make some adjustments in the above code.

Sub aTestV21()
    'New version with two new Requirements:
    '1.Date WeekNum must be less than Current WeekNum
    '2.Date Month must be less than Current Month
    'REMARK: considers first day of week = Monday
    Dim dictDay As Object, dictWeek As Object, dictMonth As Object
    Dim rcell As Range, v As Variant
    
    Set dictDay = CreateObject("Scripting.Dictionary")
    Set dictWeek = CreateObject("Scripting.Dictionary")
    Set dictMonth = CreateObject("Scripting.Dictionary")
    
    With Sheets("Index")
        For Each rcell In .Range("A2:A" & .Cells(.Rows.Count, "A").End(xlUp).Row)
            dictDay(rcell.Value2) = Empty
            
            'Check if WeekNum is less than current WeekNum
            If rcell < Date - Weekday(Date, 2) + 1 Then
                dictWeek(rcell.Value2 - Weekday(rcell.Value2, vbMonday) + 1) = Empty
            End If
            
            'Check if month is less than current month
            If rcell <= Application.EoMonth(Date, -1) Then
                dictMonth(CLng(DateSerial(Year(rcell.Value2), Month(rcell.Value2), 1))) = Empty
            End If
            
        Next rcell
        
        .Columns("G:I").ClearContents
        .Range("G1:I1").Value = Array("DailyDates", "WeeklyDates", "MonthlyDates")
        
        With .Range("G2").Resize(dictDay.Count)
            .Value = Application.Transpose(dictDay.keys)
            .Name = "DailyDates"
            .NumberFormat = "dd/mm/yyyy"
        End With
            
        If dictWeek.Count Then
            With .Range("H2").Resize(dictWeek.Count)
                .Value = Application.Transpose(dictWeek.keys)
                .Name = "WeeklyDates"
                .NumberFormat = "dd/mm/yyyy"
            End With
        Else
            .Range("H2").Name = "WeeklyDates"
        End If
        
        If dictMonth.Count Then
            With .Range("I2").Resize(dictMonth.Count)
                .Value = Application.Transpose(dictMonth.keys)
                .Name = "MonthlyDates"
                .NumberFormat = "mmm yy"
            End With
        Else
            .Range("I2").Name = "MonthlyDates"
        End If
        
        .Columns("G:I").AutoFit
        
        With .Range("J1")
            With .Validation
                .Delete
                .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
                 xlBetween, Formula1:="=if($L$1=1,DailyDates,If($L$1=2,WeeklyDates,MonthlyDates))"
                .IgnoreBlank = True
                .InCellDropdown = True
                .InputTitle = ""
                .ErrorTitle = ""
                .InputMessage = ""
                .ErrorMessage = ""
                .ShowInput = True
                .ShowError = True
            End With
            .NumberFormat = "dd/mm/yyyy"
            .ColumnWidth = 10
        End With
    End With
        
End Sub

M.

 

[Sahil123]

Sorry for the amendments and i will check it later...
following your code looks like it will do the trick..

really do appreciate your help..

can you please explain a couple of things in the code above...

1) Why do we need to transpose the keys? Is keys a 2d array?
2) why is the Clng and Dateserial used to get month
3) why is the extra if needed For dictweek.count and dictmonth.count?
4) why use value.2 and v is defined as variant but i cant see that being used in the code

If dictMonth.Count Then
With .Range("I2").Resize(dictMonth.Count)
.Value = Application.Transpose(dictMonth.keys)
.Name = "MonthlyDates"
.NumberFormat = "mmm yy"
End With
Else
.Range("I2").Name = "MonthlyDates"
End If





I understand the code but just trying to understand that part..

thank you

 

[Marcelo Branco]

1. dict.keys is an horizontal array, that's why Transpose is needed to pass the values to a vertical range
2. CLng a date is recommended specially if your Regional Setting for dates is NOT american_style (mm/dd/yyyy), as is precisely my situation here in Brasil - we use dd/mm/yyyy
3. to check if the dicts were populate with ate least one value to avoid an error when resizing the range
4. Value2 should be used when dealing with dates (again specially when Regional Setting for dates is dd/mm/yyyy)
For more informations see
https://fastexcel.wordpress.com/2011/11/30/text-vs-value-vs-value2-slow-text-and-how-to-avoid-it/
5. i was using v for testing purposes and forgot to delete it in the version i posted. It's not necessary.

By the way, all this stuff can be found in the Help file and in the internet - there are plenty of sites dealing with such subjects.

M.

 

[Sahil123]

It works superb -

Just once last bit I need to add - how can I ensure that the data validation date gets defaulted to the last date in the dictWeek just so when the code is run - it defaults for the previous week

Thank you

 

[Sahil123]

I tried

.range("J1").value = dictWeek(dictWeek.count - 1) but that didnt work

i guess that returns Empty because thats the content..

i was trying to return the actual last Key and set the data validation default value to that..

not sure how to return a key

 

[Marcelo Branco]

Add these code lines before the last End With

If dictWeek.Count Then
    .Range("L1").Value = 2
    .Range("J1").Value = .Range("H1").Offset(dictWeek.Count).Value
End If

M.