Creating dynamic List on Workbook Startup

[TrueRad]

Good morning everyone,
I'm trying to create a dynamic list once Workbook is open. Can you guys help me what is wrong with my code?

Private Sub Workbook_Open(ByVal Target As Range)
Dim d As Object, i&, arr '
    Set d = CreateObject("scripting.dictionary")
    arr = Worksheets("Temp").Range("_Nompipesize")
    Worksheets("Calc").Range("E2").Value = ""
With d
     For i = 1 To UBound(arr)
        If Not .Exists(arr(i, 1)) Then d(arr(i, 1)) = ""
    Next i
    End With
    If d.Count > 0 Then
        With Worksheets("Calc").Range("E2")
            .Validation.Delete
            .Validation.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
            xlBetween, Formula1:=Join(d.Keys, ",")
            .Value = d.Keys
        End With
    End If
End Sub

2020-04-22_6-18-50.jpg

[Artik]

Declare as:

Private Sub Workbook_Open()

Artik

[TrueRad]

Thanks a lot. Can you tell me one more thing. How to force program not to convert 3/4, 1-1/4 to date.
2020-04-22_8-14-21.jpg

[paulked]

Put an apostophe before it... '3/4

[TrueRad]

Put an apostophe before it... '3/4

I did still changes to date format. it is really enjoying

[Paul_Hossler]

Capture.JPG

I think you're over complicating it

Sizes are in Temp, A1:A8, with '3/4 and '1-3/4

Option Explicit


Private Sub Workbook_Open()


    With Worksheets("Temp")
        On Error Resume Next
        .Names("_Nompipesize").Delete
        On Error GoTo 0
        
        Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp)).Name = "_Nompipesize"
    End With
    
    With Worksheets("Calc").Range("E2")
        .ClearContents
        .Validation.Delete
        .Validation.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:="=_Nompipesize"
    End With
End Sub

[TrueRad]

Capture.JPG

I think you're over complicating it

Sizes are in Temp, A1:A8, with '3/4 and '1-3/4

Option Explicit


Private Sub Workbook_Open()


    With Worksheets("Temp")
        On Error Resume Next
        .Names("_Nompipesize").Delete
        On Error GoTo 0
        
        Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp)).Name = "_Nompipesize"
    End With
    
    With Worksheets("Calc").Range("E2")
        .ClearContents
        .Validation.Delete
        .Validation.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:="=_Nompipesize"
    End With
End Sub

Paul thank you very much. This is really nice code. I forgot to mentioned I don't want any duplicates in the list. Is there a way to do it without creating an Object "scripting.dictionary"?

[Paul_Hossler]

I forgot to mention I don't want any duplicates in the list. Is there a way to do it without creating an Object "scripting.dictionary"?

Yes, don't put duplicates in the list that the dropdown is built from

Do you need more than that?

[TrueRad]

Duplicates already exist in the list.
2020-04-28_8-03-42.jpg

[Paul_Hossler]

OK, then try this

Option Explicit


Sub Macro1()
    Dim r As Range
    Dim i As Long
    Dim s As Variant
    
    
    Set r = Worksheets("Temp").Cells(1, 1).CurrentRegion
    s = "," '   needed
    For i = 1 To r.Rows.Count - 1
        If r.Cells(i, 1).Value <> r.Cells(i + 1, 1).Value Then
            s = s & r.Cells(i, 1).Text & ","
        End If
    Next i
    
    s = Left(s, Len(s) - 1)
    
    With Worksheets("Calc").Range("E2")
        With .Validation
            .Delete
            .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:=s
            .IgnoreBlank = True
            .InCellDropdown = True
            .InputTitle = ""
            .ErrorTitle = ""
            .InputMessage = ""
            .ErrorMessage = ""
            .ShowInput = True
            .ShowError = True
        End With
    End With
    
End Sub

[TrueRad]

OK, then try this

Option Explicit


Sub Macro1()
    Dim r As Range
    Dim i As Long
    Dim s As Variant
    
    
    Set r = Worksheets("Temp").Cells(1, 1).CurrentRegion
    s = "," '   needed
    For i = 1 To r.Rows.Count - 1
        If r.Cells(i, 1).Value <> r.Cells(i + 1, 1).Value Then
            s = s & r.Cells(i, 1).Text & ","
        End If
    Next i
    
    s = Left(s, Len(s) - 1)
    
    With Worksheets("Calc").Range("E2")
        With .Validation
            .Delete
            .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:=s
            .IgnoreBlank = True
            .InCellDropdown = True
            .InputTitle = ""
            .ErrorTitle = ""
            .InputMessage = ""
            .ErrorMessage = ""
            .ShowInput = True
            .ShowError = True
        End With
    End With
    
End Sub

I had to changed the Format Cell to "Text" to make it work. Since I changed it to Text my other code will not work. Would you help me with that ? I've attached the Excel file

[Paul_Hossler]

It was a little hard for me to follow what you were attempting to do

I'm guessing that after the pipe size was selected, the validation list for the other 2 were to be restricted to only the values for that pipe size

Not a lot of error checking, and I changed the destination columns to B (easier for me to see what's going on)

Standard module:

Option Explicit


Sub ValidString(ValidCol As Long, ValidDest As Range)
    Dim r As Range
    Dim i As Long
    Dim s As Variant
    
    Set r = Worksheets("Temp").Cells(1, 1).CurrentRegion
    
    s = "," '   needed
    For i = 3 To r.Rows.Count - 1
        If r.Cells(i, ValidCol).Value <> r.Cells(i + 1, ValidCol).Value Then
            s = s & r.Cells(i, ValidCol).Text & ","
        End If
    Next i
    
    s = Left(s, Len(s) - 1)
    
    With ValidDest
        .NumberFormat = "@"
        .HorizontalAlignment = xlHAlignRight
        With .Validation
            .Delete
            .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:=s
            .IgnoreBlank = True
            .InCellDropdown = True
            .InputTitle = ""
            .ErrorTitle = ""
            .InputMessage = ""
            .ErrorMessage = ""
            .ShowInput = True
            .ShowError = True
        End With
    End With


End Sub


Sub ValidString2(ValidCol As Long, ValidDest As Range, PrimFilter As String)
    Dim r As Range
    Dim i As Long
    Dim s As Variant
    
    Set r = Worksheets("Temp").Cells(1, 1).CurrentRegion
    
    s = "," '   needed
    For i = 3 To r.Rows.Count - 1
        If r.Cells(i, ValidCol).Value <> r.Cells(i + 1, ValidCol).Value Then
            If r.Cells(i, 1).Value = PrimFilter Then
                s = s & r.Cells(i, ValidCol).Text & ","
            End If
        End If
    Next i
    
    s = Left(s, Len(s) - 1)
    
    With ValidDest
        .NumberFormat = "@"
        .HorizontalAlignment = xlHAlignRight
        With .Validation
            .Delete
            .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:=s
            .IgnoreBlank = True
            .InCellDropdown = True
            .InputTitle = ""
            .ErrorTitle = ""
            .InputMessage = ""
            .ErrorMessage = ""
            .ShowInput = True
            .ShowError = True
        End With
    End With


End Sub

ThisWorkbook:

Option Explicit


Private Sub Workbook_Open()
        
    Application.EnableEvents = False
    Call ValidString(1, Worksheets("Calc").Range("B2"))
    Worksheets("Calc").Range("B2").ClearContents
    Worksheets("Calc").Range("B3").ClearContents
    Worksheets("Calc").Range("B4").ClearContents
    Application.EnableEvents = True
   
End Sub

Worksheet Calc:

Option Explicit


Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Address <> "$B$2" Then Exit Sub
    
    Application.EnableEvents = False
    Call ValidString2(6, Worksheets("Calc").Range("B3"), Worksheets("Calc").Range("B2"))
    Call ValidString2(8, Worksheets("Calc").Range("B4"), Worksheets("Calc").Range("B2"))
    Application.EnableEvents = True


End Sub

[TrueRad]

This works really well. I'm new to VBA so I'm trying do the best I can. It will take me a while before I will fully understand your code but I learn quite a bit. Thank you very much for your help.

[Paul_Hossler]

Ask questions

The macros were pretty crude and can be more elegant

Apologies for not having more comments

In ver 2 I cleaned up the code a little, and consolidated the two validation macros to eliminate a lot of redundant code