View Full Version : Creating dynamic List on Workbook Startup
TrueRad
04-22-2020, 04:24 AM
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
04-22-2020, 04:31 AM
Declare as:
Private Sub Workbook_Open()
Artik
TrueRad
04-22-2020, 06:25 AM
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
04-22-2020, 01:40 PM
Put an apostophe before it... '3/4
TrueRad
04-23-2020, 05:12 AM
Put an apostophe before it... '3/4
I did still changes to date format. it is really enjoying
Paul_Hossler
04-23-2020, 07:46 AM
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
04-28-2020, 05:22 AM
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
04-28-2020, 05:36 AM
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
04-28-2020, 06:05 AM
Duplicates already exist in the list.
26467
Paul_Hossler
04-28-2020, 06:21 PM
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
04-29-2020, 04:57 AM
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
04-29-2020, 08:03 AM
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
04-30-2020, 06:10 AM
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
04-30-2020, 07:41 AM
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
Powered by vBulletin® Version 4.2.5 Copyright © 2024 vBulletin Solutions Inc. All rights reserved.