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


26411

[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.
26412

[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]

26421

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]

26421

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.
26467

[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