Solution to dynamically change data validation range

Question

Hello,

I have a data validation list that I want dynamically changed per number of items in a range.

For example, I have my data validation in Range(U15:U21). The values in this range can change to blank values (""). How can I configure my data validation to change to the non-blank items in this list? So if there are 4 non-blank values in U15:U21, the data validation will change to U15:U18.

Here's my code so far:

    'These are the different ranges for the data validation

    Const Range1 As String = "=$U$15"

    Const Range2 As String = "=$U$15:$U$16"

    Const Range3 As String = "=$U$15:$U$17"

    Const Range4 As String = "=$U$15:$U$18"

    Const Range5 As String = "=$U$15:$U$19"

    Const Range6 As String = "=$U$15:$U$20"

    Const Range7 As String = "=$U$15:$U$21"

    With ThisWorkbook

      'Cell U23 shows the # of non-blanks in range U15-U21

      Select Case Me.Range("U23").Value

      '1 non-blank value, set data validation to 1 list item (U15 only)

      Case "1"

        With Selection.Validation

            .Delete

            .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _

            xlBetween, Formula1:="Range1"

            .IgnoreBlank = True

            .InCellDropdown = True

            .InputTitle = ""

            .ErrorTitle = ""

            .InputMessage = ""

            .ErrorMessage = ""

            .ShowInput = True

           .ShowError = True

         End With

       End Select

     End With

I'm still very new with VBA and can't seem to figure this solution out. The code compiles, but the data validation does not change. Anyone have any advice? Thanks a ton in advance

Answer 1

Hi Norman,

Thanks a lot for the response. I've tried all three codes and it doesn't seem to work. Everything compiles ok, but when I change range (U15:U21) from say, 7 non-blank values to 4 non-bank values, the data validation still shows (U15:21).

Luckily, after a lot of digging, I was able to find a non-VBA solution online for this. I'm not sure if I'm allowed to post links on the forum but here it is for anyone's reference: http://blog.contextures.com/archives/2014/02/27/dynamic-list-with-blank-cells/

Answer 2

Hi Nitsuj5,

To correct an error, replace the preceding event code with the following version:

'=========>>

Option Explicit

'--------->>

Private Sub Worksheet_Change(ByVal Target As Range)

    Dim Rng As Range, Rng2 As Range, Rng3 As Range

    Dim iNonBlank As Long

    Const myCells As String = "U15:U21"

    Set Rng = Me.Range(myCells)

    If Not Intersect(Rng, Target) Is Nothing Then

        iNonBlank = Application.CountA(Rng)

        If CBool(iNonBlank) Then

            Set Rng2 = Rng.Resize(iNonBlank)

        End If

        If Not Rng2 Is Nothing Then

            Rng.Validation.Delete

            With Rng2.Validation

                .Add Type:=xlValidateList, _

                     AlertStyle:=xlValidAlertStop, _

                     Operator:=xlBetween, _

                     Formula1:="=" & Rng2.Address & ""

                .IgnoreBlank = True

                .InCellDropdown = True

                .InputTitle = ""

                .ErrorTitle = ""

                .InputMessage = ""

                .ErrorMessage = ""

                .ShowInput = True

                .ShowError = True

            End With

        Else

            Rng.Validation.Delete

        End If

    End If

End Sub

'<<=========

===

Regards,

Norman

Answer 3

Hi Nitsuj5,

If your intention was to use an event procedure to adjust the data validation automatically, in response to changes in the values of the range U15:U21, try instead as follows:

• Right-click the sheet tab
• Select the View Code option from the resultant context menu
• Paste the following event code:

'=========>>

Option Explicit

'--------->>

Private Sub Worksheet_Change(ByVal Target As Range)

    Dim Rng As Range, Rng2 As Range

    Dim iNonBlank As Long

    Const myCells As String = "U15:U21"

    Set Rng = Intersect(Me.Range(myCells), Target)

    If Not Rng Is Nothing Then

        iNonBlank = Application.CountA(Rng)

        If CBool(iNonBlank) Then

            Set Rng2 = Rng.Resize(iNonBlank)

        End If

        If Not Rng2 Is Nothing Then

            With Rng2.Validation

                .Delete

                .Add Type:=xlValidateList, _

                     AlertStyle:=xlValidAlertStop, _

                     Operator:=xlBetween, _

                     Formula1:="=" & Rng2.Address & ""

                .IgnoreBlank = True

                .InCellDropdown = True

                .InputTitle = ""

                .ErrorTitle = ""

                .InputMessage = ""

                .ErrorMessage = ""

                .ShowInput = True

                .ShowError = True

            End With

        Else

            Rng.Validation.Delete

        End If

    End If

End Sub

'<<=========

===

Regards,

Norman

Answer 4

Hi Nitsuj5,

Try something like:

'=========>>

Option Explicit

'--------->>

Public Sub Tester()

    Dim WB As Workbook

    Dim SH As Worksheet

    Dim Rng As Range, Rng2 As Range

    Dim iNonBlank As Long

    Const myCells As String = "U15:U21"

    Set WB = ThisWorkbook

    Set SH = WB.Sheets("Sheet1")                     '<<===== Change

    Set Rng = SH.Range(myCells)

    iNonBlank = Application.CountA(Rng)

    If CBool(iNonBlank) Then

        Set Rng2 = Rng.Resize(iNonBlank)

   End If

    If Not Rng2 Is Nothing Then

        With Rng2.Validation

            .Delete

            .Add Type:=xlValidateList, _

                 AlertStyle:=xlValidAlertStop, _

                 Operator:=xlBetween, _

                 Formula1:="=" & Rng2.Address & ""

            .IgnoreBlank = True

            .InCellDropdown = True

            .InputTitle = ""

            .ErrorTitle = ""

            .InputMessage = ""

            .ErrorMessage = ""

            .ShowInput = True

            .ShowError = True

        End With

    Else

        Rng.Validation.Delete

    End If

End Sub

'<<=========

===

Regards,

Norman