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]

Hi I have tried this and it so far appears to be working...What I need to do is work on the weekly range From H2 and then monthly range I2 and I think I would be ok ...

Anyone help me finish the code - many thanks

Sub ChangeValidation()
Dim ws As Worksheet
Dim DateRange As Range
Dim lstDailyRow As Long
Set ws = Worksheets("Index")
Set DateRange = ws.Range("RawData[Dates]")
ws.Range("G1:I10000").ClearContents
ws.Range("RawData[[#All],[Dates]]").AdvancedFilter Action:=xlFilterCopy, _
        CopyToRange:=ws.Range("G1"), Unique:=True
        
ws.Range("G1").Value = "DailyDates"
ws.Range("H1").Value = "WeeklyDates"
ws.Range("I1").Value = "MonthlyDates"
lstDailyRow = ws.Columns(7).Find(What:="*", After:=[G1], SearchOrder:=xlByRows, searchDirection:=xlPrevious).Row
ActiveWorkbook.Names("DailyDates").RefersTo = "=Index!$G$2:$G$" & lstDailyRow
  
ws.Range("J1").Clear
        
       With ws.Range("J1").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
If ws.Range("L1").Value = 3 Then
    ws.Range("J1").NumberFormat = "mmm yy"
Else
    ws.Range("J1").NumberFormat = "dd/mm/yy"
End If
End Sub

Sub FormatCellSelection()
Dim ws As Worksheet
Set ws = Worksheets("Index")
If ws.Range("L1").Value = 3 Then
    ws.Range("J1").NumberFormat = "mmm yy"
Else
    ws.Range("J1").NumberFormat = "dd/mm/yy"
End If
End Sub

 

[Sahil123]

Please can someone help me finish it off

 

[Sahil123]

Hi I have tried this and it so far appears to be working...What I need to do is work on the weekly range From H2 and then monthly range I2 and I think I would be ok ...

Anyone help me finish the code - many thanks

Sub ChangeValidation()
Dim ws As Worksheet
Dim DateRange As Range
Dim lstDailyRow As Long
Set ws = Worksheets("Index")
Set DateRange = ws.Range("RawData[Dates]")
ws.Range("G1:I10000").ClearContents
ws.Range("RawData[[#All],[Dates]]").AdvancedFilter Action:=xlFilterCopy, _
        CopyToRange:=ws.Range("G1"), Unique:=True
        
ws.Range("G1").Value = "DailyDates"
ws.Range("H1").Value = "WeeklyDates"
ws.Range("I1").Value = "MonthlyDates"
lstDailyRow = ws.Columns(7).Find(What:="*", After:=[G1], SearchOrder:=xlByRows, searchDirection:=xlPrevious).Row
ActiveWorkbook.Names("DailyDates").RefersTo = "=Index!$G$2:$G$" & lstDailyRow
  
ws.Range("J1").Clear
        
       With ws.Range("J1").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
If ws.Range("L1").Value = 3 Then
    ws.Range("J1").NumberFormat = "mmm yy"
Else
    ws.Range("J1").NumberFormat = "dd/mm/yy"
End If
End Sub

Sub FormatCellSelection()
Dim ws As Worksheet
Set ws = Worksheets("Index")
If ws.Range("L1").Value = 3 Then
    ws.Range("J1").NumberFormat = "mmm yy"
Else
    ws.Range("J1").NumberFormat = "dd/mm/yy"
End If
End Sub

I know the steps i need to follow but just not sure how to implement it..

for the weeks dates...

look into the column with daily dates....
if the any dates are still in the current week then i dont need that week date as i only want dates for previous weeks..
go through daily dates and get the monday for that date without duplicating the week dates (so if i already have the monday for that date im looking at, i dont need to duplicate it)

Once i have the weekdates i can update my named range WeeklyDates

I know the same logic will apply for the months aswel (update months up to previous months)

Hope this makes sense and someone can help me

 

[Sahil123]

Bump - please

im aware it might need an array or scripting dictionary..please can someone help me

thank you

 

[Sahil123]

Bump

 

[Marcelo Branco]

See if this does what you need

Sub aTest()
    Dim dictDay As Object, dictWeek As Object, dictMonth As Object
    Dim rCell As Range
    
    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
            dictWeek(rCell.Value2 - Weekday(rCell.Value2) + 2) = Empty
            dictMonth(Format(rCell.Value2, "mmm yy")) = Empty
        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"
        End With
            
        With .Range("H2").Resize(dictWeek.Count)
            .Value = Application.Transpose(dictWeek.keys)
            .Name = "WeeklyDates"
        End With
        
        With .Range("I2").Resize(dictMonth.Count)
            .Value = Application.Transpose(dictMonth.keys)
            .Name = "MonthlyDates"
        End With
        
        .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"
            .EntireColumn.AutoFit
        End With
    End With
        
End Sub

Hope this helps

M.

 

[Sahil123]

Thank You Mate..I will give that a go when i get home..

Just before i do test it later, can i please ask a couple of Qs if you dont mind

1) does the code input Unique dates for the daily dates
2) does the week dates have unique dates only with WC the Monday from the daily dates but not having the WC for the monday if the daily date is in the week I am running it..ie if there are daily dates that have 14/09,15/09 etc..then i should not have the WC 12/09..that WC can only be in the week dates when im in the following week..so the WC dates should always have the WC Mondays for prior weeks from the daily dates (excluding current/this week)

3) The same logic for the months also ..so prior months (not current month) ..that could only be there when im in the following month...

the idea is to see whats happened the prev days or prev weeks or prev months (i cant compare current week/month until im in the next week/month)

Does the name range override/modify the previous named range or would i need to delete the existing named range?

4) how dow the dict.add part work asim not sure how it adds the unique dates and what does = Empty do?

i apologise if ive asked too many questions..i just want to learn and understand what im doing

Thank you so much for looking at this for me

 

[Marcelo Branco]

1. Yes
2. Don't understand. What you mean by WC?
3. idem
4. The unique dates are added as the Keys of the dictionary. Empty is the Item
If you really want to learn how and when to use a Dictionary take a look at
VBA for smarties: Dictionaries
https://www.experts-exchange.com/articles/3391/Using-the-Dictionary-Class-in-VBA.html

M.

 

[Marcelo Branco]

With the data sample you provided in post#1 the code generates, as required, this in columns G:H

	G​	H​	I​
1​	DailyDates​	WeeklyDates​	MonthlyDates​
2​	15/09/2016​	12/09/2016​	set 16​
3​	16/09/2016​	19/09/2016​
4​	19/09/2016​
5​	20/09/2016​

<tbody>
</tbody>

The code, also, creates the Data Validation rules in cell J1

M.